Two Kaprekar Exercises
March 22, 2011
We begin with the function that makes a single step in a Kaprekar chain:
(define (step n)
(let* ((ds (normalize n))
(big (undigits (sort > ds)))
(little (undigits (sort < ds))))
(- big little)))
That function calls a function that adds leading zeros if needed:
(define (normalize n)
(let loop ((ds (digits n)))
(if (= (length ds) 4) ds
(loop (cons 0 ds)))))
Then it is easy to compute the chain; we stop at either 6174 or 0, where 0 occurs only if all the digits are the same:
(define (chain n)
(let loop ((ns (list n)))
(if (member (car ns) '(0 6174))
(reverse ns)
(loop (cons (step (car ns)) ns)))))
Here’s an example:
> (chain 2011)
(2011 1998 8082 8532 6174)
The longest Kaprekar chain has seven steps; we compute eight because our chain includes both the beginning and ending numbers:
> (apply max (map length (map chain (range 1 10000))))
8
Determining if a number is a Kaprekar number is a simple translation of the stated algorithm to Scheme:
(define (kaprekar? k)
(let* ((n (length (digits k)))
(k2 (* k k))
(ds (reverse (digits k2)))
(left (undigits (reverse (drop n ds))))
(right (undigits (reverse (take n ds)))))
(= (+ left right) k)))
Here’s an example:
(kaprekar? 703)
#t
There are eight Kaprekar numbers less than a thousand:
(filter kaprekar? (range 1 1000))
(1 9 45 55 99 297 703 999)
We used take, drop, range, filter, sort, digits and undigits from the Standard Prelude. You can run the program at http://programmingpraxis.codepad.org/jUEoq05B.
Programming Praxis 
[…] today’s Programming Praxis exercise,our goal is to determine the longest possible Kaprekar chain and the […]
My Haskell solution (see http://bonsaicode.wordpress.com/2011/03/22/programming-praxis-two-kaprekar-exercises/ for a version with comments):
import Data.List import qualified Data.List.Key as K import Text.Printf chain :: Int -> [Int] chain 0 = [] chain 6174 = [6174] chain n = n : chain (read (reverse p) - read p) where p = sort $ printf "%04d" n isKaprekar :: Integral a => a -> Bool isKaprekar n = n == uncurry (+) (divMod (n^2) $ 10 ^ length (show n)) main :: IO () main = do print $ chain 2011 == [2011, 1998, 8082, 8532, 6174] print . K.maximum length $ map chain [0..9999] print $ filter isKaprekar [1..999] == [1, 9, 45, 55, 99, 297, 703, 999]I believe we’ve done the second part before (exercise 169), but I came up with a
new solution this time.
My solution is available here.
My try in REXX
KAPREKAR_KONST = 6174
/* Kaprekar-Ketten */
do 10
erg = 0
do until erg = 1
zahl = right(random(1,9999),4,’0′)
erg = pruefe(zahl)
end
say ‘Die Kaprekar-Kette für’ zahl ‘lautet’,
kaprekar_kette(zahl)
end
/* Kaprekar-Zahlen */
do zahl = 1 to 10000
if kaprekar_zahl(zahl) then say,
zahl ‘ist eine Kaprekar-Zahl.’
end
exit
kaprekar_kette:
parse arg zahl
kette = zahl
do while zahl <> KAPREKAR_KONST
interpret ‘erg=’sort(zahl,’D’)’-‘sort(zahl,’A’)
kette = kette erg
zahl = erg
end
return kette
kaprekar_zahl:
parse arg zahl
q = zahl * zahl
lq = length(q)
kurz = lq % 2
lang = lq % 2
if odd(lq) then lang = lang + 1
if odd(lq) then chk = left(q,kurz) ‘+’ right(q,lang)
else chk = left(q,kurz) ‘+’ right(q,lang)
interpret ‘erg =’ chk
return erg == zahl
pruefe:
parse arg text
do x = 1 to length(text)
if verify(text, substr(text, x, 1), ‘N’) > 0
then return 1
end
return 0
sort:
parse arg text, folge
chg = 1
do while chg == 1 & length(text) > 1
chg = 0
do i = 1 to (length(text) – 1)
j = i + 1
if (folge == ‘A’ & substr(text, i, 1) >,
substr(text, j, 1) |,
folge == ‘D’ & substr(text, i, 1) <,
substr(text, j, 1))
then do
temp = substr(text,i,1)
text = overlay(substr(text,j,1), text, i, 1)
text = overlay(temp, text, j, 1)
chg = 1
end
end
end
return text
odd:
parse arg num
return (num // 2)
Sorry, forgot the formatting:
KAPREKAR_KONST = 6174 /* Kaprekar-Ketten */ do 10 erg = 0 do until erg = 1 zahl = right(random(1,9999),4,'0') erg = pruefe(zahl) end say 'Die Kaprekar-Kette für' zahl 'lautet', kaprekar_kette(zahl) end /* Kaprekar-Zahlen */ do zahl = 1 to 10000 if kaprekar_zahl(zahl) then say, zahl 'ist eine Kaprekar-Zahl.' end exit kaprekar_kette: parse arg zahl kette = zahl do while zahl <> KAPREKAR_KONST interpret 'erg='sort(zahl,'D')'-'sort(zahl,'A') kette = kette erg zahl = erg end return kette kaprekar_zahl: parse arg zahl q = zahl * zahl lq = length(q) kurz = lq % 2 lang = lq % 2 if odd(lq) then lang = lang + 1 if odd(lq) then chk = left(q,kurz) '+' right(q,lang) else chk = left(q,kurz) '+' right(q,lang) interpret 'erg =' chk return erg == zahl pruefe: parse arg text do x = 1 to length(text) if verify(text, substr(text, x, 1), 'N') > 0 then return 1 end return 0 sort: parse arg text, folge chg = 1 do while chg == 1 & length(text) > 1 chg = 0 do i = 1 to (length(text) - 1) j = i + 1 if (folge == 'A' & substr(text, i, 1) >, substr(text, j, 1) |, folge == 'D' & substr(text, i, 1) <, substr(text, j, 1)) then do temp = substr(text,i,1) text = overlay(substr(text,j,1), text, i, 1) text = overlay(temp, text, j, 1) chg = 1 end end end return text odd: parse arg num return (num // 2)In F#
let rec kaprekar_chain (n:int) = let digits = n.ToString().PadLeft(4,'0').ToCharArray() |> List.ofArray |> List.map (fun c -> (int c) - (int '0')) let ascend = List.sort digits let descend = List.rev ascend let a = List.foldBack (fun x acc -> x + acc * 10) ascend 0 let b = List.foldBack (fun x acc -> x + acc * 10) descend 0 match a - b with | 6174 -> [n;6174] | 0 -> [] | _ -> n::(kaprekar_chain (a-b)) [1..9999] |> List.maxBy (fun c -> (kaprekar_chain >> List.length) c) kaprekar_chain 14 |> List.length let isKaprekar (input:int) = match input with | 1 -> true | _ when input < 4 -> false | _ -> let n = string(input).Length let squared = string(input * input) let rightNDigits = int(squared.[(squared.Length-n) .. (squared.Length-1)]) input = int(squared.[0 .. (squared.Length - n - 1)]) + rightNDigits List.filter isKaprekar [1 .. 999]def chain(n): sz = len(str(n)) yield n while n and n != 6174: s = list(sorted(str(n),reverse=True)) if len(s) < sz: s.extend(['0']*(sz-len(s))) n = int(''.join(s)) - int(''.join(reversed(s))) yield n max(len(list(chain(n))) for n in range(1000,10000)) def isKaprekar(n): sz = len(str(n)) s = str(n*n) m = int(s[:-sz] or 0) + int(s[-sz:]) return n == m filter(isKaprekar, range(1,1000))Here is my solution in python3.
(Used a variant of Mike’r isKaprekar function. As it was cleaner than my original one. And I also wanted to understand the “int(s[:-sz] or 0)” expression)
#!/usr/bin/python3
import itertools
def isKaprekar(number):
square = str(number ** 2)
numlen = len(str(number))
return number == int(square[:-numlen] or 0) + int(square[-numlen:])
def keprekar_chain(number):
retlist = [number]
if len(set(str(number))) > 2:
while retlist[-1] != 6174:
pers = [int(”.join(x)) for x in
itertools.permutations(str(retlist[-1]))]
retlist.append(max(pers) – min(pers))
return retlist
else:
return []
if __name__ == “__main__”:
print(‘Keprekar numbers from 1 to 1000:’)
print(*[x for x in range(1,1001) if isKaprekar(x)])
print(‘Longest chain between 1000 and 9999’)
kep_list = []
for x in range(1000,10000):
tlist = keprekar_chain(x)
kep_list.append((len(tlist), tlist))
print(sorted(kep_list, key= lambda x: x[0], reverse=True)[0])
sorry, forgot formatting.
#!/usr/bin/python3import itertools
def isKaprekar(number):
square = str(number ** 2)
numlen = len(str(number))
return number == int(square[:-numlen] or 0) + int(square[-numlen:])
def keprekar_chain(number):
retlist = [number]
if len(set(str(number))) > 2:
while retlist[-1] != 6174:
pers = [int(''.join(x)) for x in
itertools.permutations(str(retlist[-1]))]
retlist.append(max(pers) - min(pers))
return retlist
else:
return []
if __name__ == "__main__":
print('Keprekar numbers from 1 to 1000:')
print(*[x for x in range(1,1001) if isKaprekar(x)])
print('Longest chain between 1000 and 9999')
kep_list = []
for x in range(1000,10000):
tlist = keprekar_chain(x)
kep_list.append((len(tlist), tlist))
print(sorted(kep_list, key= lambda x: x[0], reverse=True)[0])
3rd time’s a charm. ;)
#!/usr/bin/python3 import itertools def isKaprekar(number): square = str(number ** 2) numlen = len(str(number)) return number == int(square[:-numlen] or 0) + int(square[-numlen:]) def keprekar_chain(number): retlist = [number] if len(set(str(number))) > 2: while retlist[-1] != 6174: pers = [int(''.join(x)) for x in itertools.permutations(str(retlist[-1]))] retlist.append(max(pers) – min(pers)) return retlist else: return [] if __name__ == “__main__”: print(‘Keprekar numbers from 1 to 1000:’) print(*[x for x in range(1,1001) if isKaprekar(x)]) print(‘Longest chain between 1000 and 9999′) kep_list = [] for x in range(1000,10000): tlist = keprekar_chain(x) kep_list.append((len(tlist), tlist)) print(sorted(kep_list, key= lambda x: x[0], reverse=True)[0])My previous solution for chains was intended to work for any number, not just 4-digit numbers. However, I had hard coded the 6174 value, so it obviously only works for 4-digit numbers. Here’s a version that works for other sizes of numbers.
The line pad = … creates a function that converts a number to a string, padded with leading zeros so it has the same length as the original n.
Also, I think Remco had the best isKaprekar function. Python version below. The divmod(n*n, 10**len(str(n))) returns a tuple with the two halves of n**2. The * in front of divmod unpacks the tuple to provide the arguments to add().
#from operator import add def makeint(s): return int(''.join(s)) def chain(n): pad = '{{:0{}}}'.format(len(str(n))).format ans = [] while n not in ans: ans.append(n) s = sorted(pad(n)) n = makeint(reversed(s)) - makeint(s) return ans def isKeprekar(n): return n == add(*divmod(n*n, 10**(len(str(n))))) # this returns a chain of maximum length max((chain(n) for n in range(1000,10000)), key=len) # this returns a list of all Keprekar numbers up to 1000 filter(isKeprekar, range(1,1001));;mit scheme
(define (get-next n) (let ((asc (undigits (sort (digits n) <))) (dsc (undigits (sort (digits n) >)))) (- dsc asc))) (define (kaprekar-chains n chain) (let ((next (get-next n))) (if (= next 6174) chain (kaprekar-chains next (cons next chain))))) (kaprekar-chains 2011 (cons 2011 '())) (define (square x) (* x x)) (define (get-firstN len) (cond ((even? len) (/ len 2)) (else (- (/ (+ len 1) 2) 1)))) (define (isKaprekar? n) (let ((result (digits (square n))) (firstN (get-firstN (length (digits (square n)))))) (equal? (+ (undigits (list-head result firstN)) (undigits (list-tail result firstN))) n))) (define (integers-starting-from n) (cons-stream n (integers-starting-from (+ n 1)))) (define integers (integers-starting-from 1)) (define kapreka-numbers (stream-filter isKaprekar? integers)) ;;you can retrieve more, but it takes only first 10 numbers here. (stream-head kapreka-numbers 10)This is a solution in the concatenative language Factor.
(see http://www.factorcode.org)
USING: kernel arrays math math.order sequences sets sorting
lists lists.lazy ;
IN: kaprekar
! *** Kaprekar sequences ***
: vectorize ( n -- vec )
10 /mod swap ! output array is reverse order
10 /mod swap ! digits of n
10 /mod swap
4array ;
: vectorized>int ( vec -- n )
<reversed> 0 [ swap 10 * + ] reduce ;
: kaprekar-iteration ( n -- n )
vectorize [ <=> ] sort dup reverse [ vectorized>int ] bi@ - ;
: eligible? ( n -- ? )
dup 0000 9999 between?
swap 100 /mod = not and ;
: kaprekar-sequence ( n -- lazy-list )
dup eligible?
[ [ kaprekar-iteration ] lfrom-by [ 6174 = ] luntil ]
[ drop nil ] if ;
: longest-kaprekar-chain ( -- n )
10000 iota [ kaprekar-sequence llength ] [ max ] map-reduce ;
! *** Kaprekar numbers ***
: kaprekar-modulus ( n -- n )
1 swap
[ dup 0 > ]
[ [ 10 * ] dip 10 /i ]
while drop ;
: kaprekar? ( n -- ? )
dup dup kaprekar-modulus [ sq ] dip /mod + = ;
Results from an interactive session:
USE: kaprekar
2011 kaprekar-sequence [ ] lmap>array .
{ 2011 1998 8082 8532 6174 }
longest-kaprekar-chain .
8
703 kaprekar? .
t
1000 [1,b] [ kaprekar? ] filter .
V{ 1 9 45 55 99 297 703 999 }
Trying again. The sed script leaves much to be desired…
This is a solution in the concatenative language Factor.
(see http://www.factorcode.org)
USING: kernel arrays math math.order sequences sets sorting lists lists.lazy ; IN: kaprekar ! *** Kaprekar sequences *** : vectorize ( n -- vec ) 10 /mod swap ! output array is reverse order 10 /mod swap ! digits of n 10 /mod swap 4array ; : vectorized>int ( vec -- n ) <reversed> 0 [ swap 10 * + ] reduce ; : kaprekar-iteration ( n -- n ) vectorize [ <=> ] sort dup reverse [ vectorized>int ] bi@ - ; : eligible? ( n -- ? ) dup 0000 9999 between? swap 100 /mod = not and ; : kaprekar-sequence ( n -- lazy-list ) dup eligible? [ [ kaprekar-iteration ] lfrom-by [ 6174 = ] luntil ] [ drop nil ] if ; : longest-kaprekar-chain ( -- n ) 10000 iota [ kaprekar-sequence llength ] [ max ] map-reduce ; ! *** Kaprekar numbers *** : kaprekar-modulus ( n -- n ) 1 swap [ dup 0 > ] [ [ 10 * ] dip 10 /i ] while drop ; : kaprekar? ( n -- ? ) dup dup kaprekar-modulus [ sq ] dip /mod + = ;Session:
USE: kaprekar 2011 kaprekar-sequence [ ] lmap>array . { 2011 1998 8082 8532 6174 } longest-kaprekar-chain . 8 703 kaprekar? . t 1000 [1,b] [ kaprekar? ] filter . V{ 1 9 45 55 99 297 703 999 }