## 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)))```

```(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.

Pages: 1 2

### 14 Responses to “Two Kaprekar Exercises”

1. [...] today’s Programming Praxis exercise,our goal is to determine the longest possible Kaprekar chain and the [...]

```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]
```
3. Graham said

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.

4. Rainer said

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)

5. Rainer said

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)

```
6. Khanh Nguyen said

In F#

```let rec kaprekar_chain (n:int) =
|> 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]
```
7. Mike said
```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))

```
8. Bryce said

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])

9. Bryce said

sorry, forgot formatting.

`#!/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])`

10. Bryce said

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])
```
11. Mike said

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):

ans = []
while n not in ans:
ans.append(n)
n = makeint(reversed(s)) - makeint(s)

return ans

def isKeprekar(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))

```
12. yaq said

;;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.
```
13. David said

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 }

14. David said

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 }
```