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.

About these ads

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 [...]

  2. 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]
    
  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) =
        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]
    
  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):
    	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))
    
    
  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.
    (stream-head kapreka-numbers 10)
    
  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 }
    

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

Follow

Get every new post delivered to your Inbox.

Join 630 other followers

%d bloggers like this: