Kaprekar numbers

From Rosetta Code
Task
Kaprekar numbers
You are encouraged to solve this task according to the task description, using any language you may know.

A positive integer is a Kaprekar number if:

  • It is   1     (unity)
  • The decimal representation of its square may be split once into two parts consisting of positive integers which sum to the original number.


Note that a split resulting in a part consisting purely of 0s is not valid, as 0 is not considered positive.


Example Kaprekar numbers
  • is a Kaprekar number, as , may be split to and , and .
  • The series of Kaprekar numbers is known as A006886, and begins as .


Example process

10000 (1002) splitting from left to right:

  • The first split is [1, 0000], and is invalid; the 0000 element consists entirely of 0s, and 0 is not considered positive.
  • Slight optimization opportunity: When splitting from left to right, once the right part consists entirely of 0s, no further testing is needed; all further splits would also be invalid.


Task

Generate and show all Kaprekar numbers less than 10,000.


Extra credit

Optionally, count (and report the count of) how many Kaprekar numbers are less than 1,000,000.


Extra extra credit

The concept of Kaprekar numbers is not limited to base 10 (i.e. decimal numbers); if you can, show that Kaprekar numbers exist in other bases too.


For this purpose, do the following:

  • Find all Kaprekar numbers for base 17 between 1 and 1,000,000 (one million);
  • Display each of them in base 10 representation;
  • Optionally, using base 17 representation (use letters 'a' to 'g' for digits 10(10) to 16(10)), display each of the numbers, its square, and where to split the square.

For example, 225(10) is "d4" in base 17, its square "a52g", and a5(17) + 2g(17) = d4(17), so the display would be something like:
225   d4  a52g  a5 + 2g


Reference


Related task



11l

Translation of: Python
F k(n)
   V n2 = String(Int64(n) ^ 2)
   L(i) 0 .< n2.len
      V a = I i > 0 {Int(n2[0 .< i])} E 0
      V b = Int(n2[i ..])
      I b != 0 & a + b == n
         R 1B
   R 0B

print((1..9999).filter(x -> k(x)))
print((1..999999).filter(x -> k(x)).len)
Output:
[1, 9, 45, 55, 99, 297, 703, 999, 2223, 2728, 4879, 4950, 5050, 5292, 7272, 7777, 9999]
54

360 Assembly

Translation of: PL/I
*        Kaprekar numbers          22/03/ 2017
KAPREKAR CSECT
         USING  KAPREKAR,R13       base register
         B      72(R15)            skip savearea
         DC     17F'0'             savearea
         STM    R14,R12,12(R13)    save previous context
         ST     R13,4(R15)         link backward
         ST     R15,8(R13)         link forward
         LR     R13,R15            set addressability
         LA     R10,0              n=0
         LA     R6,1               i=1
       DO WHILE=(C,R6,LE,=F'1000000')  do i=1 to 1000000
         CVD    R6,PI                pi=i
         ZAP    PS,PI                ps=pi
         MP     PS,PI                ps=pi*pi
         ZAP    PX,PS                ps
         OI     PX+7,X'0F'           zap sign
         UNPK   SW,PX                packed PL8 to zoned CL16
         MVC    SS(16),SW            s=pic(ps,16)
         MVI    OK,X'00'             ok=false
         LA     R7,1                 j=1
       DO WHILE=(C,R7,LE,=F'15')     do j=1 to 15
         LA     R2,16                  16
         SR     R2,R7                  -j
         ST     R2,LL                  l=16-j
         LA     R2,S1                  @s1
         LA     R3,20                  20
         LA     R4,SS                  @s
         LR     R5,R7                  j
         ICM    R5,B'1000',=C' '       pad
         MVCL   R2,R4                  s1=substr(s,1,j)        
         LA     R2,S2                  @s2
         LA     R3,20                  20
         LA     R4,SS                  @s
         AR     R4,R7                  +j
         L      R5,LL                  l
         ICM    R5,B'1000',=C' '       pad
         MVCL   R2,R4                  s2=substr(s,j+1,l)
         MVC    ZZ,=20C'0'             zw=(20)'0'
         LA     R2,S1                  @s1
         LR     R3,R7                  j
         LA     R4,ZZ                  @zz
         LR     R5,R7                  j
         CLCL   R2,R4                  if substr(s1,1,j)=substr(zz,1,j)
         BE     ITERJ                  then iterate j
         LA     R2,S2                  @s2
         L      R3,LL                  l
         LA     R4,ZZ                  @zz
         L      R5,LL                  l
         CLCL   R2,R4                  if substr(s2,1,l)=substr(zz,1,l)
         BE     EXITJ                  then leave j
         XDECI  R2,S1                  unedit s1
         ST     R2,M1                  m1=s1
         XDECI  R2,S2                  unedit s2
         ST     R2,M2                  m2=s2
         L      R2,M1                  m1
         A      R2,M2                  +m2
         ST     R2,MM                  m=m1+m2
       IF C,R6,EQ,MM THEN              if i=m then
         MVI    OK,X'01'                 ok=true
         B      EXITJ                    leave j
       ENDIF    ,                      end if
ITERJ    LA     R7,1(R7)               j++
       ENDDO    ,                    enddo j
EXITJ    EQU    *                    exitj:
       IF CLI,OK,EQ,X'01',OR,C,R6,EQ,=F'1' THEN  if ok or i=1 then
         LA     R10,1(R10)               n=n+1
         XDECO  R10,PG                   edit n
         XDECO  R6,PG+12                 edit i
         XPRNT  PG,L'PG                  print buffer
       ENDIF    ,                      end if
         LA     R6,1(R6)             i++
       ENDDO    ,                  enddo i
         L      R13,4(0,R13)       restore previous savearea pointer
         LM     R14,R12,12(R13)    restore previous context
         XR     R15,R15            rc=0
         BR     R14                exit
OK       DS     X                  ok logical
LL       DS     F                  l  binary
MM       DS     F                  m  "
M1       DS     F                  m1 "
M2       DS     F                  m2 "
         DS     0D                 -- alignment for cvd
PI       DS     PL8                pi fixed decimal(15)
PM       DS     PL8                pm "
PS       DS     PL8                ps "
PX       DS     PL8                px "
SS       DC     CL20' '            s  character(20)
S1       DS     CL20               s1 "
S2       DS     CL20               s2 "
ZZ       DS     CL20               z  "
SW       DS     CL16               sw character(16)
PG       DC     CL80' '            buffer
         YREGS
         END    KAPREKAR
Output:
           1           1
           2           9
           3          45
           4          55
           5          99
           6         297
           7         703
           8         999
           9        2223
          10        2728
          11        4879
          12        4950
          13        5050
          14        5292
          15        7272
          16        7777
          17        9999
...
          53      994708
          54      999999

Ada

with extra bases from 2 up to 36 (0..9a..z)

task description wasn't clear if 1000000 for base 17 was base 17 or base 10, so i chose base 17 (17 ** 6).

with Ada.Text_IO;
with Ada.Strings.Fixed;

procedure Kaprekar2 is
   use Ada.Strings.Fixed;

   To_Digit : constant String := "0123456789abcdefghijklmnopqrstuvwxyz";

   type Int is mod 2 ** 64;
   subtype Base_Number is Int range 2 .. 36;

   From_Digit : constant array (Character) of Int :=
     ('0'    => 0,
      '1'    => 1,
      '2'    => 2,
      '3'    => 3,
      '4'    => 4,
      '5'    => 5,
      '6'    => 6,
      '7'    => 7,
      '8'    => 8,
      '9'    => 9,
      'a'    => 10,
      'b'    => 11,
      'c'    => 12,
      'd'    => 13,
      'e'    => 14,
      'f'    => 15,
      'g'    => 16,
      'h'    => 17,
      'i'    => 18,
      'j'    => 19,
      'k'    => 20,
      'l'    => 21,
      'm'    => 22,
      'n'    => 23,
      'o'    => 24,
      'p'    => 25,
      'q'    => 26,
      'r'    => 27,
      's'    => 28,
      't'    => 29,
      'u'    => 30,
      'v'    => 31,
      'w'    => 32,
      'x'    => 33,
      'y'    => 34,
      'z'    => 35,
      others => 0);

   function To_String (Item : Int; Base : Base_Number := 10) return String is
      Value       : Int := Item;
      Digit_Index : Natural;
      Result      : String (1 .. 64);
      First       : Natural := Result'Last;
   begin
      while Value > 0 loop
         Digit_Index := Natural (Value mod Base);
         Result (First) := To_Digit (Digit_Index + 1);
         Value := Value / Base;
         First := First - 1;
      end loop;
      return Result (First + 1 .. Result'Last);
   end To_String;

   procedure Get (From : String; Item : out Int; Base : Base_Number := 10) is
   begin
      Item := 0;
      for I in From'Range loop
         Item := Item * Base;
         Item := Item + From_Digit (From (I));
      end loop;
   end Get;

   function Is_Kaprekar (N : Int; Base : Base_Number := 10) return Boolean is
      Square : Int;
   begin
      if N = 1 then
         return True;
      else
         Square := N ** 2;
         declare
            Image : String := To_String (Square, Base);
            A, B  : Int;
         begin
            for I in Image'First .. Image'Last - 1 loop
               exit when Count (Image (I + 1 .. Image'Last), "0")
                 = Image'Last - I;
               Get (From => Image (Image'First .. I),
                    Item => A,
                    Base => Base);
               Get (From => Image (I + 1 .. Image'Last),
                    Item => B,
                    Base => Base);
               if A + B = N then
                  return True;
               end if;
            end loop;
         end;
      end if;
      return False;
   end Is_Kaprekar;

   Count : Natural := 0;
begin
   for I in Int range 1 .. 10_000 loop
      if Is_Kaprekar (I) then
         Count := Count + 1;
         Ada.Text_IO.Put (To_String (I) & ",");
      end if;
   end loop;
   Ada.Text_IO.Put_Line (" Total:" & Integer'Image (Count));

   for I in Int range 10_001 .. 1_000_000 loop
      if Is_Kaprekar (I) then
         Count := Count + 1;
      end if;
   end loop;
   Ada.Text_IO.Put_Line ("Kaprekar Numbers below 1000000:" &
                         Integer'Image (Count));

   Count := 0;
   Ada.Text_IO.Put_Line ("Kaprekar Numbers below 1000000 in base 17:");
   for I in Int range 1 .. 17 ** 6 loop
      if Is_Kaprekar (I, 17) then
         Count := Count + 1;
         Ada.Text_IO.Put (To_String (I, 17) & ",");
      end if;
   end loop;
   Ada.Text_IO.Put_Line (" Total:" & Integer'Image (Count));
end Kaprekar2;
Output:
1,9,45,55,99,297,703,999,2223,2728,4879,4950,5050,5292,7272,7777,9999, Total: 17
Kaprekar Numbers below 1000000: 54
Kaprekar Numbers below 1000000 in base 17:
1,g,3d,d4,gg,556,bbb,ggg,18bd,1f1f,36db,43cd,61eb,785d,7a96,967b,98b4,af26,cd44,da36,f1f2,f854,gggg,33334,ddddd,fgacc,ggggg,146fca,236985,2b32b3,2gde03,3a2d6f,3fa16d,443ccd,4e9c28,54067b,5aggb6,687534,6f6f6g,7e692a,7f391e,91d7f3,92a7e7,a1a1a1,a89bdd,b6005b,bcga96,c274e9,ccd444,d16fa4,d6e3a2,e032ge,e5de5e,eda78c,fca147,g10645,gggggg, Total: 57

ALGOL 68

# find some Kaprekar numbers                              #

# returns TRUE if n is a Kaprekar number, FALSE otherwise #
PROC is kaprekar = ( INT n )BOOL:
     IF n < 1 THEN
         # 0 and -ve numbers are not Kaprekar numbers     #
         FALSE
     ELIF n = 1 THEN
         # 1 is defined to be a Kaprekar number           #
         TRUE
     ELSE
         # n is a Kaprekar number if the digits of its    #
         # square can be partitioned into two numbers     #
         # that sum to n                                  #
         LONG INT  n squared     = LENG n * n;
         LONG INT  power of ten := 10;
         BOOL result            := FALSE;
         WHILE n squared > power of ten AND NOT result DO
             LONG INT left  = n squared OVER power of ten;
             LONG INT right = n squared  MOD power of ten;
             result := ( ( left + right ) = n AND right /= 0 );
             power of ten *:= 10
         OD;
         result
     FI # is kaprekar # ;
         
         
# count the number of Kaprekar numbers up to 1 000 000    #
# printing all those below 10 000                         #
INT max number           = 1 000 000;
INT k count             := 0;
[ 1 : 2 ]LONG INT split := ( 0, 0 );
print( ( "Kaprekar numbers below 10 000: ", newline ) );
FOR n TO max number DO
    IF is kaprekar( n ) THEN
        k count +:= 1;
        IF n < 10 000 THEN
            print( ( " ", whole( n, -4 ) ) )
        FI
    FI
OD;
print( ( newline ) );
print( ( "There are ", whole( k count, 0 ), " Kaprekar numbers below ", whole( max number, 0 ), newline ) )
Output:
Kaprekar numbers below 10 000:
    1    9   45   55   99  297  703  999 2223 2728 4879 4950 5050 5292 7272 7777 9999
There are 54 Kaprekar numbers below 1000000

Arturo

k?: function [n][
    n2: to :string n*n
    loop 0..dec size n2 'i [
        a: (i > 0)? -> to :integer slice n2 0 dec i -> 0
        b: to :integer slice n2 i dec size n2
        if and? b > 0 n = a + b -> return true
    ]
    return false
]

loop 1..10000 'x [
    if k? x -> print x
]
Output:
1
9
45
55
99
297
703
999
2223
2728
4879
4950
5050
5292
7272
7777
9999

AutoHotkey

Function:

Kaprekar(L) {
    Loop, % L + ( C := 0 ) {
        S := ( N := A_Index ) ** 2
        Loop % StrLen(N) {
            B := ( B := SubStr(S,1+A_Index) ) ? B : 0
            If !B & ( (A := SubStr(S,1,A_Index)) <> 1 )
                Break
            If ( N == A+B ) {
                R .= ", " N , C++
                Break
            }
        }
    }
    Return C " Kaprekar numbers in [1-" L "]:`n" SubStr(R,3)
}

Usage:

MsgBox, % Kaprekar(10000)
Output:
17 Kaprekar numbers in [1-10000]:
1, 9, 45, 55, 99, 297, 703, 999, 2223, 2728, 4879, 4950, 5050, 5292, 7272, 7777, 9999

AWK

# syntax: GAWK -f KAPREKAR_NUMBERS.AWK
BEGIN {
    limit = 1000000
    printf("%d\n",1)
    n = 1
    for (i=2; i<limit; i++) {
      squared = sprintf("%.0f",i*i)
      for (j=1; j<=length(squared); j++) {
        L = substr(squared,1,j) + 0
        R = substr(squared,j+1) + 0
        if (R == 0) {
          continue
        }
        if (L + R == i) {
          n++
          if (i <= 10000) {
            printf("%d\n",i)
          }
          break
        }
      }
    }
    printf("%d Kaprekar numbers < %s\n",n,limit)
    exit(0)
}
Output:
1
9
45
55
99
297
703
999
2223
2728
4879
4950
5050
5292
7272
7777
9999
54 Kaprekar numbers < 1000000

Batch File

@echo off
setlocal enabledelayedexpansion

for /l %%i in (1,1,9999) do (
  title Processing - %%i
  call:kaprekar %%i
)

pause>nul
exit /b

:kaprekar
set num=%1
if %num% leq 0 exit /b
set /a num2=%num%*%num%

if %num2% leq 9 (
  if %num2%==%num% (
    echo %num%
    exit /b
  ) else (
    exit /b
  )
)

call:strlength %num2%
set len=%errorlevel%
set /a offset=%len%-1
set tempcount=1

:loop

set /a offset2=%len%-%tempcount%
set numleft=!num2:~0,%tempcount%!
set numright=!num2:~%tempcount%,%offset2%!

for /f "tokens=* delims=0" %%i in ("%numright%") do set "numright=%%i"
if not defined numright exit /b
set /a sum=%numleft%+%numright%

if %sum%==%num% (
  echo %num%
  exit /b
)

if %tempcount%==%len% exit /b
set /a tempcount+=1
goto loop

:strlength
setlocal enabledelayedexpansion
set str=%1
set tempcount=1
:lengthloop
set /a length=%tempcount%-1
if "!str:~%tempcount%,1!"=="" exit /b %tempcount%
set /a tempcount+=1
goto lengthloop
Output:
1
9
45
55
99
297
703
999
2223
2728
4879
4950
5050
5292
7272
7777
9999

BASIC

BASIC256

n = 0
for i = 1 to 1999999
	if Kaprekar(i) then
		n = n + 1
		if i < 100001 then print n; ": "; i
	endif
next i
print
print "Total de números de Kaprekar por debajo de 1.000.000 = "; n
end

function Kaprekar(n)
	s = n ^ 2
	t = 10 ^ (int(log(s)) + 1)
	do
		t = t / 10
		if t <= n then exit do #break
		if s-n = int(s/t)*(t-1) then return TRUE
	until t <= n
	return n = 1
end function

BBC BASIC

      *FLOAT 64
      n% = 0
      FOR i% = 1 TO 999999
        IF FNkaprekar(i%) THEN
          n% += 1
          IF i% < 100001PRINT ; n% ":", i%
        ENDIF
      NEXT
      PRINT "Total Kaprekar numbers under 1,000,000 = "; n%
      END
      
      DEF FNkaprekar(n)
      LOCAL s, t
      s = n^2
      t = 10^(INT(LOG(s)) + 1)
      REPEAT
        t /= 10
        IF t<=n EXIT REPEAT
        IF s-n = INT(s/t)*(t-1) THEN = TRUE
      UNTIL FALSE
      = (n=1)
Output:
1:                 1
2:                 9
3:                45
4:                55
5:                99
6:               297
7:               703
8:               999
9:              2223
10:             2728
11:             4879
12:             4950
13:             5050
14:             5292
15:             7272
16:             7777
17:             9999
18:            17344
19:            22222
20:            38962
21:            77778
22:            82656
23:            95121
24:            99999
Total Kaprekar numbers under 1,000,000 = 54

Bracmat

( 0:?n
& 1:?count
& out$(!count 1)
&   whl
  ' ( 1+!n:<1000000:?n
    & ( @( !n^2
         :   #?a
             ( ? (#>0:?b)
             & !a+!b:!n
             & 1+!count:?count
             & (!n:<10000&out$!n|)
             )
         )
      |
      )
    )
& out$(str$("There are " !count " kaprekar numbers less than 1000000"))
);
Output:
1 1
9
45
55
99
297
703
999
2223
2728
4879
4950
5050
5292
7272
7777
9999
There are 54 kaprekar numbers less than 1000000

Brat

kaprekar = { limit |
  results = []

  1.to limit, { num |
    true? num == 1
    { results << 1 }
    {
      sqr = (num ^ 2).to_s

      0.to (sqr.length - 1) { i |
        lhs = sqr[0,i].to_i
        rhs = sqr[i + 1,-1].to_i

        true? (rhs > 0) && { lhs + rhs == num }
        { results << num }
      }
    }
  }

  results
}

p "Kaprekar numbers below 10,000:"
p kaprekar 10000

p "Number of Kaprekar numbers below 1,000,000:"
p kaprekar(1000000).length
Output:
Kaprekar numbers below 10,000:
[1, 9, 45, 55, 99, 297, 703, 999, 2223, 2728, 4879, 4950, 5050, 5292, 7272, 7777, 9999]
Number of Kaprekar numbers below 1,000,000:
54

C

Sample for extra extra credit:

#include <stdio.h>
#include <stdint.h>
typedef uint64_t ulong;

int kaprekar(ulong n, int base)
{
	ulong nn = n * n, r, tens = 1;

	if ((nn - n) % (base - 1)) return 0;

	while (tens < n) tens *= base;
	if (n == tens) return 1 == n;

	while ((r = nn % tens) < n) {
		if (nn / tens + r == n) return tens;
		tens *= base;
	}

	return 0;
}

void print_num(ulong n, int base)
{
	ulong q, div = base;

	while (div < n) div *= base;
	while (n && (div /= base)) {
		q = n / div;
		if (q < 10)     putchar(q + '0');
		else            putchar(q + 'a' - 10);
		n -= q * div;
	}
}

int main()
{
	ulong i, tens;
	int cnt = 0;
	int base = 10;

	printf("base 10:\n");
	for (i = 1; i < 1000000; i++)
		if (kaprekar(i, base))
			printf("%3d: %llu\n", ++cnt, i);

	base = 17;
	printf("\nbase %d:\n  1: 1\n", base);
	for (i = 2, cnt = 1; i < 1000000; i++)
		if ((tens = kaprekar(i, base))) {
			printf("%3d: %llu", ++cnt, i);
			printf(" \t"); print_num(i, base);
			printf("\t");  print_num(i * i, base);
			printf("\t");  print_num(i * i / tens, base);
			printf(" + "); print_num(i * i % tens, base);
			printf("\n");
		}

	return 0;
}
Output:
base 10:
  1: 1
  2: 9
  3: 45
  4: 55
  5: 99
  6: 297
  7: 703
  8: 999
  9: 2223
 10: 2728
 11: 4879
 12: 4950
 13: 5050
 14: 5292
 15: 7272
 16: 7777
 17: 9999
 ...
 47: 791505
 48: 812890
 49: 818181
 50: 851851
 51: 857143
 52: 961038
 53: 994708
 54: 999999

base 17:
  1: 1
  2: 16 	g	f1	f + 1
  3: 64 	3d	e2g	e + 2g
  4: 225 	d4	a52g	a5 + 2g
  5: 288 	gg	gf01	gf + 1
  6: 1536 	556	1b43b2	1b4 + 3b2
  7: 3377 	bbb	8093b2	809 + 3b2
  8: 4912 	ggg	ggf001	ggf + 1
  9: 7425 	18bd	24e166g	24e + 166g
 10: 9280 	1f1f	39b1b94	39b + 1b94
 ...
 21: 74241 	f1f2	d75f1b94	d75f + 1b94
 22: 76096 	f854	e1f5166g	e1f5 + 166g
 23: 83520 	gggg	gggf0001	gggf + 1
 24: 266224 	33334	a2c52a07g	a2c5 + 2a07g

Factorization

Kaprekar numbers for base can be directly generated by factorization of and multiplicative inverse of its unitary divisors. The speed largely depends on how easy the factorization part is, though it's not a problem for relatively small numbers (up to 32-bits, for example).

#include <stdio.h>
#include <stdlib.h>
#include <stdint.h>
#include <limits.h>

typedef signed long long xint;

int factorize(xint n, xint* f)
{
	int i = 0;

	inline void get_factor(xint p) {
		if (n % p) return;
		for (f[i] = 1; !(n % p); f[i] *= p, n /= p);
		i++;
	}

	get_factor(2);
	get_factor(3);
	xint p, inc;
	for (p = 5, inc = 4; p * p <= n; p += (inc = 6 - inc))
		get_factor(p);
	if (n > 1) get_factor(n);
	return i;
}

// returns x where a x == 1 mod b
xint mul_inv(xint a, xint b)
{
	xint b0 = b, t, q;
	xint x0 = 0, x1 = 1;
	if (b == 1) return 1;
	while (a > 1) {
		q = a / b;
		t = b, b = a % b, a = t;
		t = x0, x0 = x1 - q * x0, x1 = t;
	}
	if (x1 < 0) x1 += b0;
	return x1;
}

int kaprekars(int base, xint top, xint *out, int max_cnt)
{
	xint f[64], pb;
	int len, cnt = 0;

	if (top >= LLONG_MAX / top) {
		fprintf(stderr, "too large: %lld\n", top);
		abort();
	}

	void kaps(xint a, int i) {
		if (i < len) {
			kaps(a * f[i], i + 1);
			kaps(a, i + 1);
			return;
		}

		xint x = a * mul_inv(a, (pb - 1) / a);
		if (x > 1 && x < top) {
			out[cnt++] = x;
			if (cnt >= max_cnt) {
				fprintf(stderr, "too many results\n");
				abort();
			}
		}
	}

	out[cnt++] = 1;

	for (pb = base; pb <= top * top / base; pb *= base) {
		len = factorize(pb - 1, f);
		if (f[len - 1] <= top) kaps(1, 0);
	}
	return cnt;
}

int main(void)
{
	xint x[1000];
	int len, b;
	
	for (b = 2; b < 99; b++) {
		printf("base %d:\n", b);

		// find all kaprekar numbers that won't overflow
		len = kaprekars(b, INT_MAX, x, 1000);
#if 0
		int i, j;
		xint t;
		for (i = 0; i < len; i++)
			for (j = 0; j < i; j++)
				if (x[i] < x[j])
					t = x[i], x[i] = x[j], x[j] = t;

		for (i = 0; i < len; i++)
			printf("%3d: %lld\n", i + 1, x[i]);
#else
		printf("\t%d kaprepar numbers\n", len);
#endif
	}

	return 0;
}

C#

using System;
using System.Collections.Generic;

public class KaprekarNumbers {

    /// <summary>
    /// The entry point of the program, where the program control starts and ends.
    /// </summary>
    public static void Main() {
        int count = 0;

        foreach ( ulong i in _kaprekarGenerator(999999) ) {
            Console.WriteLine(i);
            count++;
        }

        Console.WriteLine("There are {0} Kaprekar numbers less than 1000000.", count);
    }

    /// <summary>
    /// Generator function which generates the Kaprekar numbers.
    /// </summary>
    /// <returns>The generator.</returns>
    /// <param name="max">The maximum value of the numbers generated.</param>
    private static IEnumerable<ulong> _kaprekarGenerator(ulong max) {

        ulong next = 1;

        // 1 is always a Kaprekar number.
        yield return next;

        for ( next = 2; next <= max; next++ ) {

            ulong square = next * next;

            for ( ulong check = 10; check <= 10000000000000000000; check *= 10 ) {
                // Check the square against each power of 10 from 10^1 to 10^19 (highest which can be
                // represented by a ulong)

                // If the power of 10 to be checked against is greater than or equal to the square, stop checking
                if ( square <= check )
                    break;

                // Given a power of 10 as 10^n, the remainder when dividing the square number by that power
                // of 10 is equal to the last n digits of the number (starting from the right) and the
                // quotient gives the remaining digits.
                // If the last n digits are all zeroes, then the remainder will be zero, which is not
                // accepted.

                ulong r = square % check;
                ulong q = (square - r) / check;

                if ( r != 0 && q + r == next ) {
                    yield return next;
                    break;
                }
            }

        }

    }

}
Output:
1
9
45
55
99
297
703
999
2223
2728
4879
4950
5050
5292
7272
7777
9999
17344
22222
38962
77778
82656
95121
99999
142857
148149
181819
187110
208495
318682
329967
351352
356643
390313
461539
466830
499500
500500
533170
538461
609687
627615
643357
648648
670033
681318
791505
812890
818181
851851
857143
961038
994708
999999
There are 54 Kaprekar numbers less than 1000000.

C++

Using String Manipulation (very slow)

#include <vector>
#include <string>
#include <iostream>
#include <sstream>
#include <algorithm>
#include <iterator>
#include <utility>

long string2long( const std::string & s ) {
   long result ;
   std::istringstream( s ) >> result ;
   return result ;
}

bool isKaprekar( long number ) {
   long long squarenumber = ((long long)number) * number ;
   std::ostringstream numberbuf ;
   numberbuf << squarenumber ;
   std::string numberstring = numberbuf.str( ) ;
   for ( int i = 0 ; i < numberstring.length( ) ; i++ ) {
      std::string firstpart = numberstring.substr( 0 , i ) ,
                  secondpart = numberstring.substr( i ) ;
      //we do not accept figures ending in a sequence of zeroes
      if ( secondpart.find_first_not_of( "0" ) == std::string::npos ) {
	 return false ;
      }
      if ( string2long( firstpart ) + string2long( secondpart ) == number ) {
	 return true ;
      }
   }
   return false ;
}

int main( ) {
   std::vector<long> kaprekarnumbers ;
   kaprekarnumbers.push_back( 1 ) ;
   for ( int i = 2 ; i < 1000001 ; i++ ) {
      if ( isKaprekar( i ) ) 
	 kaprekarnumbers.push_back( i ) ;
   }
   std::vector<long>::const_iterator svi = kaprekarnumbers.begin( ) ;
   std::cout << "Kaprekar numbers up to 10000: \n" ;
   while ( *svi < 10000 ) {
      std::cout << *svi << " " ;
      svi++ ;
   }
   std::cout << '\n' ;
   std::cout << "All the Kaprekar numbers up to 1000000 :\n" ;
   std::copy( kaprekarnumbers.begin( ) , kaprekarnumbers.end( ) ,
	 std::ostream_iterator<long>( std::cout , "\n" ) ) ;
   std::cout << "There are " << kaprekarnumbers.size( )
      << " Kaprekar numbers less than one million!\n" ;
   return 0 ;
}
Output:
Kaprekar numbers up to 10000: 
1 9 45 55 99 297 703 999 2223 2728 4879 4950 5050 5292 7272 7777 9999 
All the Kaprekar numbers up to 1000000 :
1
9
45
55
99
297
703
999
2223
2728
4879
4950
5050
5292
7272
7777
9999
17344
.....
818181
851851
857143
961038
994708
999999
There are 54 Kaprekar numbers less than one million!

Casting Out Nines (fast)

The code "if ((k*(k-1))%(Base-1) == 0)" is explained here: Casting out nines.

// Generate Kaperkar Numbers
//
// Nigel Galloway. June 24th., 2012
//
#include <iostream>
int main() {
	const int Base = 10;
	const int N = 6;
	int Paddy_cnt = 0;
	for (int nz=1; nz<=N; nz++)
		for (unsigned long long int k=pow((double)Base,nz-1); k<pow((double)Base,nz); k++)
			if ((k*(k-1))%(Base-1) == 0)
				for (int n=nz; n<nz*2; n++){
					const unsigned long long int B = pow((double)Base,n);
					const double nr = k*(B-k)/(B-1);
					const int q = k-nr;
					if ((k*k==q*B+nr && 0<nr)){
						std::cout << std::dec << ++Paddy_cnt << ": " << k << " is "  << q << " + " << (int)nr << " and squared is " << k*k << ". It is a member of Residual Set " << k%(Base-1) << "\n";
						break;
				}}
	return 0;
}

Produces:

1: 1 is 0 + 1 and squared is 1. It is a member of Residual Set 1
2: 9 is 8 + 1 and squared is 81. It is a member of Residual Set 0
3: 45 is 20 + 25 and squared is 2025. It is a member of Residual Set 0
4: 55 is 30 + 25 and squared is 3025. It is a member of Residual Set 1
5: 99 is 98 + 1 and squared is 9801. It is a member of Residual Set 0
6: 297 is 88 + 209 and squared is 88209. It is a member of Residual Set 0
7: 703 is 494 + 209 and squared is 494209. It is a member of Residual Set 1
8: 999 is 998 + 1 and squared is 998001. It is a member of Residual Set 0
9: 2223 is 494 + 1729 and squared is 4941729. It is a member of Residual Set 0
10: 2728 is 744 + 1984 and squared is 7441984. It is a member of Residual Set 1
11: 4879 is 238 + 4641 and squared is 23804641. It is a member of Residual Set 1
12: 4950 is 2450 + 2500 and squared is 24502500. It is a member of Residual Set 0
13: 5050 is 2550 + 2500 and squared is 25502500. It is a member of Residual Set 1
14: 5292 is 28 + 5264 and squared is 28005264. It is a member of Residual Set 0
15: 7272 is 5288 + 1984 and squared is 52881984. It is a member of Residual Set 0
16: 7777 is 6048 + 1729 and squared is 60481729. It is a member of Residual Set 1
17: 9999 is 9998 + 1 and squared is 99980001. It is a member of Residual Set 0
18: 17344 is 3008 + 14336 and squared is 300814336. It is a member of Residual Set 1
19: 22222 is 4938 + 17284 and squared is 493817284. It is a member of Residual Set 1
20: 38962 is 1518 + 37444 and squared is 1518037444. It is a member of Residual Set 1
21: 77778 is 60494 + 17284 and squared is 6049417284. It is a member of Residual Set 0
22: 82656 is 68320 + 14336 and squared is 6832014336. It is a member of Residual Set 0
23: 95121 is 90480 + 4641 and squared is 9048004641. It is a member of Residual Set 0
24: 99999 is 99998 + 1 and squared is 9999800001. It is a member of Residual Set 0
25: 142857 is 20408 + 122449 and squared is 20408122449. It is a member of Residual Set 0
26: 148149 is 21948 + 126201 and squared is 21948126201. It is a member of Residual Set 0
27: 181819 is 33058 + 148761 and squared is 33058148761. It is a member of Residual Set 1
28: 187110 is 35010 + 152100 and squared is 35010152100. It is a member of Residual Set 0
29: 208495 is 43470 + 165025 and squared is 43470165025. It is a member of Residual Set 1
30: 318682 is 101558 + 217124 and squared is 101558217124. It is a member of Residual Set 1
31: 329967 is 108878 + 221089 and squared is 108878221089. It is a member of Residual Set 0
32: 351352 is 123448 + 227904 and squared is 123448227904. It is a member of Residual Set 1
33: 356643 is 127194 + 229449 and squared is 127194229449. It is a member of Residual Set 0
34: 390313 is 152344 + 237969 and squared is 152344237969. It is a member of Residual Set 1
35: 461539 is 213018 + 248521 and squared is 213018248521. It is a member of Residual Set 1
36: 466830 is 217930 + 248900 and squared is 217930248900. It is a member of Residual Set 0
37: 499500 is 249500 + 250000 and squared is 249500250000. It is a member of Residual Set 0
38: 500500 is 250500 + 250000 and squared is 250500250000. It is a member of Residual Set 1
39: 533170 is 284270 + 248900 and squared is 284270248900. It is a member of Residual Set 1
40: 538461 is 289940 + 248521 and squared is 289940248521. It is a member of Residual Set 0
41: 609687 is 371718 + 237969 and squared is 371718237969. It is a member of Residual Set 0
42: 627615 is 39390 + 588225 and squared is 393900588225. It is a member of Residual Set 0
43: 643357 is 413908 + 229449 and squared is 413908229449. It is a member of Residual Set 1
44: 648648 is 420744 + 227904 and squared is 420744227904. It is a member of Residual Set 0
45: 670033 is 448944 + 221089 and squared is 448944221089. It is a member of Residual Set 1
46: 681318 is 464194 + 217124 and squared is 464194217124. It is a member of Residual Set 0
47: 791505 is 626480 + 165025 and squared is 626480165025. It is a member of Residual Set 0
48: 812890 is 660790 + 152100 and squared is 660790152100. It is a member of Residual Set 1
49: 818181 is 669420 + 148761 and squared is 669420148761. It is a member of Residual Set 0
50: 851851 is 725650 + 126201 and squared is 725650126201. It is a member of Residual Set 1
51: 857143 is 734694 + 122449 and squared is 734694122449. It is a member of Residual Set 1
52: 961038 is 923594 + 37444 and squared is 923594037444. It is a member of Residual Set 0
53: 994708 is 989444 + 5264 and squared is 989444005264. It is a member of Residual Set 1
54: 999999 is 999998 + 1 and squared is 999998000001. It is a member of Residual Set 0

The code may be modified to use a base other than 10:

const int Base = 16;
const int N = 4;
std::cout << std::dec << ++Paddy_cnt << ": " << std::hex << k << " is "  << q << " + " << (int)nr << " and squared is " << k*k << ". It is a member of Residual Set " << k%(Base-1) << "\n";

Which produces:

1: 1 is 0 + 1 and squared is 1. It is a member of Residual Set 1
2: 6 is 2 + 4 and squared is 24. It is a member of Residual Set 6
3: a is 6 + 4 and squared is 64. It is a member of Residual Set a
4: f is e + 1 and squared is e1. It is a member of Residual Set 0
5: 33 is a + 29 and squared is a29. It is a member of Residual Set 6
6: 55 is 1c + 39 and squared is 1c39. It is a member of Residual Set a
7: 5b is 2 + 59 and squared is 2059. It is a member of Residual Set 1
8: 78 is 38 + 40 and squared is 3840. It is a member of Residual Set 0
9: 88 is 48 + 40 and squared is 4840. It is a member of Residual Set 1
10: ab is 72 + 39 and squared is 7239. It is a member of Residual Set 6
11: cd is a4 + 29 and squared is a429. It is a member of Residual Set a
12: ff is fe + 1 and squared is fe01. It is a member of Residual Set 0
13: 15f is 1e + 141 and squared is 1e141. It is a member of Residual Set 6
14: 334 is a4 + 290 and squared is a4290. It is a member of Residual Set a
15: 38e is ca + 2c4 and squared is ca2c4. It is a member of Residual Set a
16: 492 is 14e + 344 and squared is 14e344. It is a member of Residual Set 0
17: 4ed is 184 + 369 and squared is 184369. It is a member of Residual Set 1
18: 7e0 is 3e0 + 400 and squared is 3e0400. It is a member of Residual Set 6
19: 820 is 420 + 400 and squared is 420400. It is a member of Residual Set a
20: b13 is 7aa + 369 and squared is 7aa369. It is a member of Residual Set 0
21: b6e is 82a + 344 and squared is 82a344. It is a member of Residual Set 1
22: c72 is 9ae + 2c4 and squared is 9ae2c4. It is a member of Residual Set 6
23: ccc is a3c + 290 and squared is a3c290. It is a member of Residual Set 6
24: ea1 is d60 + 141 and squared is d60141. It is a member of Residual Set a
25: fa5 is f4c + 59 and squared is f4c059. It is a member of Residual Set 0
26: fff is ffe + 1 and squared is ffe001. It is a member of Residual Set 0
27: 191a is 276 + 16a4 and squared is 27616a4. It is a member of Residual Set 6
28: 2a2b is 6f2 + 2339 and squared is 6f22339. It is a member of Residual Set a
29: 3c3c is e2c + 2e10 and squared is e2c2e10. It is a member of Residual Set 0
30: 4444 is 1234 + 3210 and squared is 12343210. It is a member of Residual Set 1
31: 5556 is 1c72 + 38e4 and squared is 1c7238e4. It is a member of Residual Set 6
32: 6667 is 28f6 + 3d71 and squared is 28f63d71. It is a member of Residual Set a
33: 7f80 is 3f80 + 4000 and squared is 3f804000. It is a member of Residual Set 0
34: 8080 is 4080 + 4000 and squared is 40804000. It is a member of Residual Set 1
35: 9999 is 5c28 + 3d71 and squared is 5c283d71. It is a member of Residual Set 6
36: aaaa is 71c6 + 38e4 and squared is 71c638e4. It is a member of Residual Set a
37: bbbc is 89ac + 3210 and squared is 89ac3210. It is a member of Residual Set 0
38: c3c4 is 95b4 + 2e10 and squared is 95b42e10. It is a member of Residual Set 1
39: d5d5 is b29c + 2339 and squared is b29c2339. It is a member of Residual Set 6
40: e6e6 is d042 + 16a4 and squared is d04216a4. It is a member of Residual Set a
41: ffff is fffe + 1 and squared is fffe0001. It is a member of Residual Set 0

Casting Out Nines C++11 For Each Generator (v.fast)

For details of ran and co9 see: http://rosettacode.org/wiki/Casting_out_nines#C.2B.2B11_For_Each_Generator

// Generate Kaprekar Numbers using Casting Out Nines Generator
//
// Nigel Galloway. July 13th., 2012
//
#include <cmath>
int main() {
	const ran r(10);
	int Paddy_cnt = 0;
	for (int nz=1; nz<=6; nz++)
		for (unsigned long long int k : co9(std::pow(r.base,nz-1),std::pow(r.base,nz)-1,&r))
			for (int n=nz; n<nz*2; n++) {
				const unsigned long long int B = pow(r.base,n);
				const double nr = k*(B-k)/(B-1);
				const int q = k-nr;
				if (k*k==q*B+nr && 0<nr) {
					std::cout << ++Paddy_cnt << ": " << k << " is "  << q << " + " << (int)nr << " and squared is " << k*k << ". It is a member of Residual Set " << k%(r.base-1) << "\n";
			}}
	return 0;
}

Produces:

1: 1 is 0 + 1 and squared is 1. It is a member of Residual Set 1
2: 9 is 8 + 1 and squared is 81. It is a member of Residual Set 0
3: 45 is 20 + 25 and squared is 2025. It is a member of Residual Set 0
4: 55 is 30 + 25 and squared is 3025. It is a member of Residual Set 1
5: 99 is 98 + 1 and squared is 9801. It is a member of Residual Set 0
6: 297 is 88 + 209 and squared is 88209. It is a member of Residual Set 0
7: 703 is 494 + 209 and squared is 494209. It is a member of Residual Set 1
8: 999 is 998 + 1 and squared is 998001. It is a member of Residual Set 0
9: 2223 is 494 + 1729 and squared is 4941729. It is a member of Residual Set 0
10: 2728 is 744 + 1984 and squared is 7441984. It is a member of Residual Set 1
11: 4879 is 238 + 4641 and squared is 23804641. It is a member of Residual Set 1
12: 4950 is 2450 + 2500 and squared is 24502500. It is a member of Residual Set 0
13: 5050 is 2550 + 2500 and squared is 25502500. It is a member of Residual Set 1
14: 5292 is 28 + 5264 and squared is 28005264. It is a member of Residual Set 0
15: 7272 is 5288 + 1984 and squared is 52881984. It is a member of Residual Set 0
16: 7777 is 6048 + 1729 and squared is 60481729. It is a member of Residual Set 1
17: 9999 is 9998 + 1 and squared is 99980001. It is a member of Residual Set 0
18: 17344 is 3008 + 14336 and squared is 300814336. It is a member of Residual Set 1
19: 22222 is 4938 + 17284 and squared is 493817284. It is a member of Residual Set 1
20: 38962 is 1518 + 37444 and squared is 1518037444. It is a member of Residual Set 1
21: 77778 is 60494 + 17284 and squared is 6049417284. It is a member of Residual Set 0
22: 82656 is 68320 + 14336 and squared is 6832014336. It is a member of Residual Set 0
23: 95121 is 90480 + 4641 and squared is 9048004641. It is a member of Residual Set 0
24: 99999 is 99998 + 1 and squared is 9999800001. It is a member of Residual Set 0
25: 142857 is 20408 + 122449 and squared is 20408122449. It is a member of Residual Set 0
26: 148149 is 21948 + 126201 and squared is 21948126201. It is a member of Residual Set 0
27: 181819 is 33058 + 148761 and squared is 33058148761. It is a member of Residual Set 1
28: 187110 is 35010 + 152100 and squared is 35010152100. It is a member of Residual Set 0
29: 208495 is 43470 + 165025 and squared is 43470165025. It is a member of Residual Set 1
30: 318682 is 101558 + 217124 and squared is 101558217124. It is a member of Residual Set 1
31: 329967 is 108878 + 221089 and squared is 108878221089. It is a member of Residual Set 0
32: 351352 is 123448 + 227904 and squared is 123448227904. It is a member of Residual Set 1
33: 356643 is 127194 + 229449 and squared is 127194229449. It is a member of Residual Set 0
34: 390313 is 152344 + 237969 and squared is 152344237969. It is a member of Residual Set 1
35: 461539 is 213018 + 248521 and squared is 213018248521. It is a member of Residual Set 1
36: 466830 is 217930 + 248900 and squared is 217930248900. It is a member of Residual Set 0
37: 499500 is 249500 + 250000 and squared is 249500250000. It is a member of Residual Set 0
38: 500500 is 250500 + 250000 and squared is 250500250000. It is a member of Residual Set 1
39: 533170 is 284270 + 248900 and squared is 284270248900. It is a member of Residual Set 1
40: 538461 is 289940 + 248521 and squared is 289940248521. It is a member of Residual Set 0
41: 609687 is 371718 + 237969 and squared is 371718237969. It is a member of Residual Set 0
42: 627615 is 39390 + 588225 and squared is 393900588225. It is a member of Residual Set 0
43: 643357 is 413908 + 229449 and squared is 413908229449. It is a member of Residual Set 1
44: 648648 is 420744 + 227904 and squared is 420744227904. It is a member of Residual Set 0
45: 670033 is 448944 + 221089 and squared is 448944221089. It is a member of Residual Set 1
46: 681318 is 464194 + 217124 and squared is 464194217124. It is a member of Residual Set 0
47: 791505 is 626480 + 165025 and squared is 626480165025. It is a member of Residual Set 0
48: 812890 is 660790 + 152100 and squared is 660790152100. It is a member of Residual Set 1
49: 818181 is 669420 + 148761 and squared is 669420148761. It is a member of Residual Set 0
50: 851851 is 725650 + 126201 and squared is 725650126201. It is a member of Residual Set 1
51: 857143 is 734694 + 122449 and squared is 734694122449. It is a member of Residual Set 1
52: 961038 is 923594 + 37444 and squared is 923594037444. It is a member of Residual Set 0
53: 994708 is 989444 + 5264 and squared is 989444005264. It is a member of Residual Set 1
54: 999999 is 999998 + 1 and squared is 999998000001. It is a member of Residual Set 0

Changing main:

	const ran r = ran(16);
					std::cout << std::dec << ++Paddy_cnt << ": " << std::hex << k << " is "  << q << " + " << (int)nr << " and squared is " << k*k << ". It is a member of Residual Set " << k%(r.base-1) << "\n";

Produces:

1: 1 is 0 + 1 and squared is 1. It is a member of Residual Set 1
2: 6 is 2 + 4 and squared is 24. It is a member of Residual Set 6
3: a is 6 + 4 and squared is 64. It is a member of Residual Set a
4: f is e + 1 and squared is e1. It is a member of Residual Set 0
5: 33 is a + 29 and squared is a29. It is a member of Residual Set 6
6: 55 is 1c + 39 and squared is 1c39. It is a member of Residual Set a
7: 5b is 2 + 59 and squared is 2059. It is a member of Residual Set 1
8: 78 is 38 + 40 and squared is 3840. It is a member of Residual Set 0
9: 88 is 48 + 40 and squared is 4840. It is a member of Residual Set 1
10: ab is 72 + 39 and squared is 7239. It is a member of Residual Set 6
11: cd is a4 + 29 and squared is a429. It is a member of Residual Set a
12: ff is fe + 1 and squared is fe01. It is a member of Residual Set 0
13: 15f is 1e + 141 and squared is 1e141. It is a member of Residual Set 6
14: 334 is a4 + 290 and squared is a4290. It is a member of Residual Set a
15: 38e is ca + 2c4 and squared is ca2c4. It is a member of Residual Set a
16: 492 is 14e + 344 and squared is 14e344. It is a member of Residual Set 0
17: 4ed is 184 + 369 and squared is 184369. It is a member of Residual Set 1
18: 7e0 is 3e0 + 400 and squared is 3e0400. It is a member of Residual Set 6
19: 820 is 420 + 400 and squared is 420400. It is a member of Residual Set a
20: b13 is 7aa + 369 and squared is 7aa369. It is a member of Residual Set 0
21: b6e is 82a + 344 and squared is 82a344. It is a member of Residual Set 1
22: c72 is 9ae + 2c4 and squared is 9ae2c4. It is a member of Residual Set 6
23: ccc is a3c + 290 and squared is a3c290. It is a member of Residual Set 6
24: ea1 is d60 + 141 and squared is d60141. It is a member of Residual Set a
25: fa5 is f4c + 59 and squared is f4c059. It is a member of Residual Set 0
26: fff is ffe + 1 and squared is ffe001. It is a member of Residual Set 0
27: 191a is 276 + 16a4 and squared is 27616a4. It is a member of Residual Set 6
28: 2a2b is 6f2 + 2339 and squared is 6f22339. It is a member of Residual Set a
29: 3c3c is e2c + 2e10 and squared is e2c2e10. It is a member of Residual Set 0
30: 4444 is 1234 + 3210 and squared is 12343210. It is a member of Residual Set 1
31: 5556 is 1c72 + 38e4 and squared is 1c7238e4. It is a member of Residual Set 6
32: 6667 is 28f6 + 3d71 and squared is 28f63d71. It is a member of Residual Set a
33: 7f80 is 3f80 + 4000 and squared is 3f804000. It is a member of Residual Set 0
34: 8080 is 4080 + 4000 and squared is 40804000. It is a member of Residual Set 1
35: 9999 is 5c28 + 3d71 and squared is 5c283d71. It is a member of Residual Set 6
36: aaaa is 71c6 + 38e4 and squared is 71c638e4. It is a member of Residual Set a
37: bbbc is 89ac + 3210 and squared is 89ac3210. It is a member of Residual Set 0
38: c3c4 is 95b4 + 2e10 and squared is 95b42e10. It is a member of Residual Set 1
39: d5d5 is b29c + 2339 and squared is b29c2339. It is a member of Residual Set 6
40: e6e6 is d042 + 16a4 and squared is d04216a4. It is a member of Residual Set a
41: ffff is fffe + 1 and squared is fffe0001. It is a member of Residual Set 0

CLU

% This program assumes a 64-bit system.
% On a 32-bit system, the main task (show Kaprekar numbers < 10,000)
% will run correctly, but the extra credit part will crash with
% an overflow exception.

% Yield all positive splits of a number
splits = iter (n, base: int) yields (int,int)
    step: int := base
    while n >= step do
        left: int := n / step
        right: int := n // step 
        if left ~= 0 & right ~= 0 then
            yield(left, right)
        end
        step := step * base
    end
end splits

% Check whether a number is a Kaprekar number, and if so,
% return the proper split.
kap_split = struct[left, right: int]
maybe_kap = oneof[yes: kap_split, no: null]  
kaprekar = proc (n, base: int) returns (maybe_kap)
    for left, right: int in splits(n**2, base) do
        if left + right = n then 
            return(maybe_kap$make_yes(
                kap_split${left:left, right:right})) 
        end
    end
    return(maybe_kap$make_no(nil))
end kaprekar

% Format a number in a given base
to_base = proc (n, base: int) returns (string)
    own digits: string := "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    if n=0 then return("0") end
    ds: array[char] := array[char]$[]
    while n>0 do
        array[char]$addl(ds,digits[n // base + 1])
        n := n / base
    end
    return(string$ac2s(ds))
end to_base

% If a number is a Kaprekar number, show it, its square, and the split
display = proc (o: stream, n, base: int)
    tagcase kaprekar(n, base)
        tag yes (s: kap_split):
            stream$putright(o, to_base(n, 10), 6)
            if base ~= 10 then
                stream$putright(o, to_base(n, base), 7)
            end
            stream$putright(o, to_base(n**2, base), 13)
            stream$putl(o, "  " || 
                        to_base(s.left, base) || " + " ||
                        to_base(s.right, base))
       tag no:
    end
end display

start_up = proc ()
    po: stream := stream$primary_output()
    
    % Find and output all the Kaprekar numbers under 10,000.
    stream$putl(po, "Kaprekar numbers < 10,000:")
    for i: int in int$from_to(1, 9999) do
        display(po, i, 10)
    end
    
    % Count all the Kaprekar numbers under 1,000,000.
    kaps: int := 0
    for i: int in int$from_to(1, 999999) do
        tagcase kaprekar(i, 10)
            tag yes (s: kap_split): kaps := kaps + 1
            tag no:
        end
    end
    stream$putl(po, "\nThere are " || int$unparse(kaps) || 
                " Kaprekar numbers under 1,000,000.\n")
                
    % Find and output all base-17 Kaprekar numbers under 1,000,000.
    stream$putl(po, "Base-17 Kaprekar numbers < 1,000,000:")
    for i: int in int$from_to(1, 999999) do
        display(po, i, 17)
    end
end start_up
Output:
Kaprekar numbers < 10,000:
     9           81  8 + 1
    45         2025  20 + 25
    55         3025  30 + 25
    99         9801  98 + 1
   297        88209  88 + 209
   703       494209  494 + 209
   999       998001  998 + 1
  2223      4941729  494 + 1729
  2728      7441984  744 + 1984
  4879     23804641  238 + 4641
  4950     24502500  2450 + 2500
  5050     25502500  2550 + 2500
  5292     28005264  28 + 5264
  7272     52881984  5288 + 1984
  7777     60481729  6048 + 1729
  9999     99980001  9998 + 1

There are 53 Kaprekar numbers under 1,000,000.

Base-17 Kaprekar numbers < 1,000,000:
    16      G           F1  F + 1
    64     3D          E2G  E + 2G
   225     D4         A52G  A5 + 2G
   288     GG         GF01  GF + 1
  1536    556       1B43B2  1B4 + 3B2
  3377    BBB       8093B2  809 + 3B2
  4912    GGG       GGF001  GGF + 1
  7425   18BD      24E166G  24E + 166G
  9280   1F1F      39B1B94  39B + 1B94
 16705   36DB      B992C42  B99 + 2C42
 20736   43CD     10DE32FG  10DE + 32FG
 30016   61EB     23593F92  2359 + 3F92
 36801   785D     351E433G  351E + 433G
 37440   7A96     37144382  3714 + 4382
 46081   967B     52G94382  52G9 + 4382
 46720   98B4     5575433G  5575 + 433G
 53505   AF26     6GA43F92  6GA4 + 3F92
 62785   CD44     9A5532FG  9A55 + 32FG
 66816   DA36     AEG42C42  AEG4 + 2C42
 74241   F1F2     D75F1B94  D75F + 1B94
 76096   F854     E1F5166G  E1F5 + 166G
 83520   GGGG     GGGF0001  GGGF + 1
266224  33334    A2C52A07G  A2C5 + 2A07G

CoffeeScript

Translation of: Kotlin
splitAt = (str, idx) ->
    ans = [ str.substring(0, idx), str.substring(idx) ]
    if ans[0] == ""
        ans[0] = "0"
    ans

getKaprekarParts = (longValue, sqrStr, base) ->
    for j in [ 0 .. sqrStr.length / 2 ]
        parts = splitAt(sqrStr, j)
        nums = (parseInt(n, base) for n in parts)

        # if the right part is all zeroes, then it will be forever, so break
        if nums[1] == 0
            return null
        if nums[0] + nums[1] == longValue
            return parts
    null

base = 10
count = 0
max = 1000000
for i in [1..max]
    i2 = i * i
    s = i2.toString(base)
    p = getKaprekarParts i, s, base
    if p
        console.log i, i.toString(base), s, p.join '+'
        count++
console.log "#{count} Kaprekar numbers < #{max} (base 10) in base #{base}"
Output:
1 '1' '1' '0+1'
9 '9' '81' '8+1'
45 '45' '2025' '20+25'
55 '55' '3025' '30+25'
99 '99' '9801' '98+01'
297 '297' '88209' '88+209'
703 '703' '494209' '494+209'
999 '999' '998001' '998+001'
...
999999 '999999' '999998000001' '999998+000001'
54 Kaprekar numbers < 1000000 (base 10) in base 10

Common Lisp

Fast solution using casting out nines filter

;; make an infinite list whose accumulated sums give all
;; numbers n where n mod (base - 1) == n^2 mod (base - 1)
(defun res-list (base)
    (let* ((b (- base 1))
           (l (remove-if-not
		    (lambda (x) (= (rem x b) (rem (* x x) b)))
		    (loop for x from 0 below b collect x)))
	   (ret (append l (list b)))
	   (cycle (mapcar #'- (cdr ret) ret)))
	(setf (cdr (last cycle)) cycle)))
 
(defun kaprekar-p (n &optional (base 10))
   "tests if n is kaprekar in base; if so, return left and right half"
   (let ((nn (* n n)) (tens 1))
	; Find a start value for base power.  nn/tens + (nn mod tens) == n
	; can't be sastified if tens <= n: nn/tens = n * n / tens > n
	(loop while (< tens n) do
	      (setf tens (* tens base)))
	(if (= tens n)  ; n a power of base, can't be a solution except 1
	    (if (= n 1) (values T 0 1))
	    (loop
	       (let ((left (truncate nn tens)) (right (mod nn tens)))
		    (cond ((>= right n) (return nil))
			  ((= n (+ left right)) (return (values T left right))))
		    (setf tens (* base tens)))))))
 
(defun ktest (top &optional (base 10))
   (format t "   #    Value     Left    Right       Squared (base ~D)~%" base)
   (let ((fmt (format nil "~~4D ~~~D,8R ~~~D,8R ~~~D,8R ~~~D,13R~~%"
                      base base base base base))
	 (res (res-list base))
	 (n 0))
   	 (loop with cnt = 0 while (<= n top) do
	 	(setf n (+ n (car res)))
		(setf res (cdr res))
	 	(multiple-value-bind (k l r) (kaprekar-p n base)
		   (when k (format t fmt (incf cnt) n l r (* n n)))))))
 
(ktest 1000000)
(terpri)
(ktest 1000000 17)
Output:
   #      Value       Left      Right         Squared (base 10)
   1          1          0          1               1
   2          9          8          1              81
   3         45         20         25            2025
   4         55         30         25            3025
   5         99         98          1            9801
...
  52     961038     923594      37444    923594037444
  53     994708     989444       5264    989444005264
  54     999999     999998          1    999998000001

   #      Value       Left      Right         Squared (base 17)
   1          1          0          1               1
   2          G          F          1              F1
   3         3D          E         2G             E2G
...
  22       F854       E1F5       166G        E1F5166G
  23       GGGG       GGGF          1        GGGF0001
  24      33334       A2C5      2A07G       A2C52A07G

In the style of the C++ generator

;; Generate Kaprekar Numbers using Casting Out Nines Generator
;;
;; Nigel Galloway - October 1st., 2012
;;
(defconstant Base 10)
(defconstant MAX 1000000)
(defconstant ran (let ((N ()) (Base-1 (- Base 1))) (do ((cnt Base-1 (- cnt 1))) ((zerop cnt) (return N))
   (if (= (mod (* cnt (- cnt 1)) Base-1) 0) (setf N (cons cnt N))))))

(defun kap () (let ((Paddy_cnt 0) (Base-1 (- Base 1))) (do ((n 0 (+ n Base-1))) ((> n MAX) ()) (dolist (G ran)
   (let ((N (+ G n))) (if (>= MAX N) (let ((kk (* N N))) (do ((B Base (* B Base))) (nil)
     (let (( nr (/ (* N (- B N)) (- B 1)))) (if (< 0 nr) (let ((q (floor (- N nr)))) (if (= kk (+ nr (* q B)))
       (format t "~3d: ~8d is ~8d + ~8d and squared is ~8d~&" (incf Paddy_cnt) N q nr kk))
     (if (> B kk) (return)))))))))))))
Output:
  1:        1 is        0 +        1 and squared is 1
  2:        9 is        8 +        1 and squared is 81
  3:       45 is       20 +       25 and squared is 2025
  4:       55 is       30 +       25 and squared is 3025
  5:       99 is       98 +        1 and squared is 9801
  6:      297 is       88 +      209 and squared is 88209
  7:      703 is      494 +      209 and squared is 494209
  8:      999 is      998 +        1 and squared is 998001
  9:     2223 is      494 +     1729 and squared is 4941729
 10:     2728 is      744 +     1984 and squared is 7441984
 11:     4879 is      238 +     4641 and squared is 23804641
 12:     4950 is     2450 +     2500 and squared is 24502500
 13:     5050 is     2550 +     2500 and squared is 25502500
 14:     5292 is       28 +     5264 and squared is 28005264
 15:     7272 is     5288 +     1984 and squared is 52881984
 16:     7777 is     6048 +     1729 and squared is 60481729
 17:     9999 is     9998 +        1 and squared is 99980001
 18:    17344 is     3008 +    14336 and squared is 300814336
 19:    22222 is     4938 +    17284 and squared is 493817284
 20:    38962 is     1518 +    37444 and squared is 1518037444
 21:    77778 is    60494 +    17284 and squared is 6049417284
 22:    82656 is    68320 +    14336 and squared is 6832014336
 23:    95121 is    90480 +     4641 and squared is 9048004641
 24:    99999 is    99998 +        1 and squared is 9999800001
 25:   142857 is    20408 +   122449 and squared is 20408122449
 26:   148149 is    21948 +   126201 and squared is 21948126201
 27:   181819 is    33058 +   148761 and squared is 33058148761
 28:   187110 is    35010 +   152100 and squared is 35010152100
 29:   208495 is    43470 +   165025 and squared is 43470165025
 30:   318682 is   101558 +   217124 and squared is 101558217124
 31:   329967 is   108878 +   221089 and squared is 108878221089
 32:   351352 is   123448 +   227904 and squared is 123448227904
 33:   356643 is   127194 +   229449 and squared is 127194229449
 34:   390313 is   152344 +   237969 and squared is 152344237969
 35:   461539 is   213018 +   248521 and squared is 213018248521
 36:   466830 is   217930 +   248900 and squared is 217930248900
 37:   499500 is   249500 +   250000 and squared is 249500250000
 38:   500500 is   250500 +   250000 and squared is 250500250000
 39:   533170 is   284270 +   248900 and squared is 284270248900
 40:   538461 is   289940 +   248521 and squared is 289940248521
 41:   609687 is   371718 +   237969 and squared is 371718237969
 42:   627615 is    39390 +   588225 and squared is 393900588225
 43:   643357 is   413908 +   229449 and squared is 413908229449
 44:   648648 is   420744 +   227904 and squared is 420744227904
 45:   670033 is   448944 +   221089 and squared is 448944221089
 46:   681318 is   464194 +   217124 and squared is 464194217124
 47:   791505 is   626480 +   165025 and squared is 626480165025
 48:   812890 is   660790 +   152100 and squared is 660790152100
 49:   818181 is   669420 +   148761 and squared is 669420148761
 50:   851851 is   725650 +   126201 and squared is 725650126201
 51:   857143 is   734694 +   122449 and squared is 734694122449
 52:   961038 is   923594 +    37444 and squared is 923594037444
 53:   994708 is   989444 +     5264 and squared is 989444005264
 54:   999999 is   999998 +        1 and squared is 999998000001

With the following timings:

; cpu time (non-gc) 4.680028 sec user, 0.140401 sec system
; cpu time (gc)     3.369624 sec user, 0.015600 sec system
; cpu time (total)  8.049652 sec user, 0.156001 sec system
; real time  8.196000 sec
; space allocation:
;  1,901 cons cells, 674,485,072 other bytes, 0 static bytes

Changing (defconstant MAX 10000000) adds the following:

 55:  4444444 is  1975308 +  2469136 and squared is 19753082469136
 56:  4927941 is  2428460 +  2499481 and squared is 24284602499481
 57:  5072059 is  2572578 +  2499481 and squared is 25725782499481
 58:  5479453 is   300244 +  5179209 and squared is 30024405179209
 59:  5555556 is  3086420 +  2469136 and squared is 30864202469136
 60:  8161912 is   666168 +  7495744 and squared is 66616807495744
 61:  9372385 is  8784160 +   588225 and squared is 87841600588225
 62:  9999999 is  9999998 +        1 and squared is 99999980000001

With the following timings:

; cpu time (non-gc) 73.850878 sec (00:01:13.850878) user, 0.140400 sec system
; cpu time (gc)     43.274673 sec user, 0.000000 sec system
; cpu time (total)  117.125551 sec (00:01:57.125551) user, 0.140400 sec system
; real time  117.441000 sec (00:01:57.441000)
; space allocation:
;  3,224 cons cells, 242,904,552 other bytes, 0 static bytes

Changing:

(defconstant Base 16)
(defconstant MAX (* 256 256))
(format t "~3d: ~6x is ~6x + ~6x and squared is ~6x~&" Paddy_cnt Nigel q nr kk)

Produces:

  1:      1 is      0 +      1 and squared is      1
  2:      6 is      2 +      4 and squared is     24
  3:      a is      6 +      4 and squared is     64
  4:      f is      e +      1 and squared is     e1
  5:     33 is      a +     29 and squared is    a29
  6:     55 is     1c +     39 and squared is   1c39
  7:     5b is      2 +     59 and squared is   2059
  8:     78 is     38 +     40 and squared is   3840
  9:     88 is     48 +     40 and squared is   4840
 10:     ab is     72 +     39 and squared is   7239
 11:     cd is     a4 +     29 and squared is   a429
 12:     ff is     fe +      1 and squared is   fe01
 13:    15f is     1e +    141 and squared is  1e141
 14:    334 is     a4 +    290 and squared is  a4290
 15:    38e is     ca +    2c4 and squared is  ca2c4
 16:    492 is    14e +    344 and squared is 14e344
 17:    4ed is    184 +    369 and squared is 184369
 18:    7e0 is    3e0 +    400 and squared is 3e0400
 19:    820 is    420 +    400 and squared is 420400
 20:    b13 is    7aa +    369 and squared is 7aa369
 21:    b6e is    82a +    344 and squared is 82a344
 22:    c72 is    9ae +    2c4 and squared is 9ae2c4
 23:    ccc is    a3c +    290 and squared is a3c290
 24:    ea1 is    d60 +    141 and squared is d60141
 25:    fa5 is    f4c +     59 and squared is f4c059
 26:    fff is    ffe +      1 and squared is ffe001
 27:   191a is    276 +   16a4 and squared is 27616a4
 28:   2a2b is    6f2 +   2339 and squared is 6f22339
 29:   3c3c is    e2c +   2e10 and squared is e2c2e10
 30:   4444 is   1234 +   3210 and squared is 12343210
 31:   5556 is   1c72 +   38e4 and squared is 1c7238e4
 32:   6667 is   28f6 +   3d71 and squared is 28f63d71
 33:   7f80 is   3f80 +   4000 and squared is 3f804000
 34:   8080 is   4080 +   4000 and squared is 40804000
 35:   9999 is   5c28 +   3d71 and squared is 5c283d71
 36:   aaaa is   71c6 +   38e4 and squared is 71c638e4
 37:   bbbc is   89ac +   3210 and squared is 89ac3210
 38:   c3c4 is   95b4 +   2e10 and squared is 95b42e10
 39:   d5d5 is   b29c +   2339 and squared is b29c2339
 40:   e6e6 is   d042 +   16a4 and squared is d04216a4
 41:   ffff is   fffe +      1 and squared is fffe0001

With the following timings:

; cpu time (non-gc) 0.109200 sec user, 0.140401 sec system
; cpu time (gc)     0.109202 sec user, 0.000000 sec system
; cpu time (total)  0.218402 sec user, 0.140401 sec system
; real time  0.345000 sec
; space allocation:
;  1,253 cons cells, 22,987,752 other bytes, 0 static bytes

D

Straightforward Version

import std.stdio, std.conv, std.algorithm, std.range;

bool isKaprekar(in long n) pure /*nothrow*/ @safe
in {
    assert(n > 0, "isKaprekar(n) is defined for n > 0.");
} body {
    if (n == 1)
        return true;
    immutable sn = text(n ^^ 2);

    foreach (immutable i; 1 .. sn.length) {
        immutable a = sn[0 .. i].to!long;
        immutable b = sn[i .. $].to!long;
        if (b && a + b == n)
            return true;
    }

    return false;
}

void main() {
    iota(1, 10_000).filter!isKaprekar.writeln;
    iota(1, 1_000_000).count!isKaprekar.writeln;
}
Output:
[1, 9, 45, 55, 99, 297, 703, 999, 2223, 2728, 4879, 4950, 5050, 5292, 7272, 7777, 9999]
54

Faster Version

Right to left:

bool isKaprekar(in uint n) pure nothrow @nogc @safe {
    ulong powr = n ^^ 2UL;
    ulong r, l, tens = 10;
    while (r < n) {
        r = powr % tens;
        l = powr / tens;
        if (r && (l + r == n))
            return true;
        tens *= 10;
    }
    return false;
}

void main() {
    import std.stdio;

    int count = 1;
    foreach (immutable i; 1 .. 1_000_000)
        if (i.isKaprekar)
            writefln("%d: %d", count++, i);
}
Output:
1: 1
2: 9
3: 45
4: 55
5: 99
6: 297
7: 703
8: 999
9: 2223
10: 2728
11: 4879
12: 4950
13: 5050
14: 5292
15: 7272
16: 7777
17: 9999
...
51: 857143
52: 961038
53: 994708
54: 999999

Delphi

Works with: Delphi version 6.0


function IsKaprekar(N: integer): boolean;
{Return true if N is a Kaperkar number}
var S,S1,S2: string;
var N1,N2,Sum: cardinal;
var Sp: integer;
begin
Result:=True;
if N=1 then exit;
{Convert N^2 to string}
S:=IntToStr(N * N);
{Try all different splits}
for Sp:=2 to Length(S) do
	begin
	{Split into two strings}
	S1:=Copy(S,1,Sp-1);
	S2:=Copy(S,Sp,(Length(S)-Sp)+1);
	{Convert to integers}
	N1:=StrToInt(S1);
	N2:=StrToInt(S2);
	{Zeros aren't allowed}
	if (N1=0) or (N2=0) then continue;
	{Test if sum matches original number}
	Sum:=N1 + N2;
	if Sum=N then exit;
	end;
Result:=False;
end;


procedure ShowKaprekarNumbers(Memo: TMemo);
{Find all Kaprekar numbers less than 10,000}
var S: string;
var I: integer;
begin
for I:=1 to 10000 do
	begin
	if IsKaprekar(I) then Memo.Lines.Add(IntToStr(I));
	end;
end;
Output:
1
9
45
55
99
297
703
999
2223
2728
4879
4950
5050
5292
7272
7777
9999


Dart

import 'dart:math';
  void main()
{
  
  int x1;
  for(x1=1;x1<1000000;x1++){
  int x;
  int i,y,y1,l1,z,l;
  double o,o1,o2,o3;
   x=pow(x1,2);
  for(i=0;;i++)
  {z=pow(10,i);
  if(x%z==x)break;}
if(i.isEven)
{
  y=pow(10,i/2);
  l=x%y;
  o=x/y;
  o=o-l/y;
  o3=o;
 for(int j=0;j<4;j++)
 {
   if(o%10==0)
     o=o/10;
   if(o%10!=0)
     break;
 }
  if(o+l==x1 ||o3+l==x1 )
     print('$x1');
  
}
  else

  {  y1=pow(10,i/2+0.5);
  l1=x%y1;
  o1=x/y1;
  o1=o1-l1/y1;
   o2=o1;
   for(int j=0;j<4;j++)
 {
   if(o1%10==0)
     o1=o1/10;
   else break;
 }
  if(o1+l1==x1 ||o2+l1==x1 )
    print('$x1');
  }
}
}

EasyLang

func karp n .
   h = n * n
   e = 1
   while h > 0
      t += h mod 10 * e
      e = e * 10
      h = h div 10
      if t > 0 and h + t = n
         return 1
      .
   .
.
for i to 9999
   if karp i = 1
      write i & " "
   .
.
Output:
1 9 45 55 99 297 703 999 2223 2728 4879 4950 5050 5292 7272 7777 9999 

Elixir

Translation of: Ruby
defmodule KaprekarNumber do
  def check(n), do: check(n, 10)
  
  def check(1,_base), do: {"1", ""}
  def check(n, base) when rem(n*(n-1), (base-1)) != 0, do: false      # casting out nine
  def check(n, base) do
    square = Integer.to_string(n*n, base)
    check(n, base, square, 1, String.length(square)-1)
  end
  
  defp check(_, _, _, _, 0), do: false
  defp check(n, base, square, i, remainder) do
    {a, b} = String.split_at(square, i)
    if String.to_integer(b, base) == 0 do
      false
    else
      sum = String.to_integer(a, base) + String.to_integer(b, base)
      if n == sum, do: {a, b}, else: check(n, base, square, i+1, remainder-1)
    end
  end
end

Enum.each(1..9_999, fn n ->
  if result = KaprekarNumber.check(n) do
    {a, b} = result
    :io.fwrite "~6w  ~8s  ~s + ~s~n", [n, a<>b, a, b]
  end
end)

# Extra credit
count = Enum.reduce(1..999_999, 0, fn n,acc ->
  if KaprekarNumber.check(n), do: acc + 1, else: acc
end)
IO.puts "\n#{count} kaprekar numbers under 1,000,000"

# Extra extra credit
base = 17
IO.puts "\nbase #{base} kaprekar numbers under 1,000,000(base10)"
Enum.each(1..999_999, fn n ->
  if result = KaprekarNumber.check(n, base) do
    {a, b} = result
    :io.fwrite "~7w  ~5s  ~9s  ~s + ~s~n", [n, Integer.to_string(n,base), a<>b, a, b]
  end
end)
Output:
     1         1  1 +
     9        81  8 + 1
    45      2025  20 + 25
    55      3025  30 + 25
    99      9801  98 + 01
   297     88209  88 + 209
   703    494209  494 + 209
   999    998001  998 + 001
  2223   4941729  494 + 1729
  2728   7441984  744 + 1984
  4879  23804641  238 + 04641
  4950  24502500  2450 + 2500
  5050  25502500  2550 + 2500
  5292  28005264  28 + 005264
  7272  52881984  5288 + 1984
  7777  60481729  6048 + 1729
  9999  99980001  9998 + 0001

54 kaprekar numbers under 1,000,000

base 17 kaprekar numbers under 1,000,000(base10)
      1      1          1  1 +
     16      G         F1  F + 1
     64     3D        E2G  E + 2G
    225     D4       A52G  A5 + 2G
    288     GG       GF01  GF + 01
   1536    556     1B43B2  1B4 + 3B2
   3377    BBB     8093B2  809 + 3B2
   4912    GGG     GGF001  GGF + 001
   7425   18BD    24E166G  24E + 166G
   9280   1F1F    39B1B94  39B + 1B94
  16705   36DB    B992C42  B99 + 2C42
  20736   43CD   10DE32FG  10DE + 32FG
  30016   61EB   23593F92  2359 + 3F92
  36801   785D   351E433G  351E + 433G
  37440   7A96   37144382  3714 + 4382
  46081   967B   52G94382  52G9 + 4382
  46720   98B4   5575433G  5575 + 433G
  53505   AF26   6GA43F92  6GA4 + 3F92
  62785   CD44   9A5532FG  9A55 + 32FG
  66816   DA36   AEG42C42  AEG4 + 2C42
  74241   F1F2   D75F1B94  D75F + 1B94
  76096   F854   E1F5166G  E1F5 + 166G
  83520   GGGG   GGGF0001  GGGF + 0001
 266224  33334  A2C52A07G  A2C5 + 2A07G

Erlang

-mode(compile).
-import(lists, [seq/2]).

kaprekar(1) -> true;
kaprekar(N) when N < 1 -> false;
kaprekar(N) ->
    Sq = N*N,
    if
        (N rem 9) =/= (Sq rem 9) -> false;
        true -> kaprekar(N, Sq, 10)
    end.

kaprekar(_, Sq,  M) when (Sq div M) =:= 0 -> false;
kaprekar(N, Sq, M) ->
    L = Sq div M,
    R = Sq rem M,
    if
        R =/= 0 andalso (L + R) =:= N -> true;
        true -> kaprekar(N, Sq, M * 10)
    end.

main(_) ->
    Numbers = [N || N <- seq(1, 9999), kaprekar(N)],
    io:format("The Kaprekar numbers < 10,000 are ~p~n", [Numbers]),

    CountTo1e6 = length(Numbers) + length([N || N <- seq(10001, 999999), kaprekar(N)]),
    io:format("There are ~p Kaprekar numbers < 1,000,000", [CountTo1e6]).
Output:
The Kaprekar numbers < 10,000 are [1,9,45,55,99,297,703,999,2223,2728,4879,
                                   4950,5050,5292,7272,7777,9999]
There are 54 Kaprekar numbers < 1,000,000

Euler Math Toolbox

This example is incorrect. It does not accomplish the given task. Please fix the code and remove this message.
>function map kaprekarp (n) ...
$  m=n*n;
$  p=10;
$  repeat
$    i=floor(m/p);
$    j=mod(m,p);
$    if j==0 then return 0; endif;
$    if i+j==n then return 1; endif;
$    p=p*10;
$    until p>m;
$  end;
$  return 0;
$endfunction
>nonzeros(kaprekarp(1:100000))
 [ 1  9  45  55  99  297  703  999  2223  2728  4879  5292  7272  7777
 9999  17344  22222  38962  77778  82656  95121  99999 ]

F#

// Count digits in number
let digits x =
    let rec digits' p x =
        if 10.**p > x then p else digits' (p + 1.) x
    digits' 1. x


// Is n a Kaprekar number?
let isKaprekar n =
    // Reference: http://oeis.org/A006886
    // Positive numbers n such that n=q+r
    // And n^2=q*10^m+r,
    //  for some m >= 1,
    //  q>=0 and 0<=r<10^m,
    //  with n != 10^a, a>=1.
    let nSquared = n * n
    let a = float((digits n) - 1.)

    // Create a list of tuples from the nSquared digit splits
    [1. .. float (digits nSquared)]
    |> List.map (fun e ->
        // Splits the nSquared digits into 2 parts
        let x = 10.**e
        let q = float(int(Math.Floor (nSquared / x)))
        let r = nSquared - (q * x)
        (q, r))
    // Filter results based on rules
    |> List.exists (fun (q, r) ->
        q + r = n &&
        if a >= 1. then n % 10.**a <> 0. else true)


// List Kaprekar numbers from 1 to 10,000
[1 .. 10000]
|> List.filter (float >> isKaprekar)

Factor

This solution is based on the following Haskell code: [1].

USING: io kernel lists lists.lazy locals math math.functions
math.ranges prettyprint sequences ;

:: kaprekar? ( n -- ? )
    n sq :> sqr
    1 lfrom
    [ 10 swap ^ ] lmap-lazy
    [ n > ] lfilter
    [ sqr swap mod n < ] lwhile
    list>array
    [ 1 - sqr n - swap mod zero? ] any?
    n 1 = or ;

1,000,000 [1,b] [ kaprekar? ] filter dup . length
"Count of Kaprekar numbers <= 1,000,000: " write .
Output:
V{
    1
    9
    45
    55
    99
    297
    703
    999
    2223
    2728
    4879
    4950
    5050
    5292
    7272
    7777
    9999
    ...
    851851
    857143
    961038
    994708
    999999
}
Count of Kaprekar numbers <= 1,000,000: 54

Forth

This one takes the internal Forth variable BASE into account. Since Forth is perfectly suited to work with any base between 2 and 36, this works just fine.

: square ( n - n^2)   dup * ; 

\ Return nonzero if n is a Kaprekar number for tens, where tens is a 
\ nonzero power of base. 
: is-kaprekar? ( tens n n^2 - t)   rot /mod  over >r  + =  r> and ; 

\ If n is a Kaprekar number, return is the power of base for which it 
\ is Kaprekar.  If n is not a Kaprekar number, return zero. 
: kaprekar ( +n - +n1) 
    dup square >r 
    base @ swap 
    begin ( tens n) ( R: n^2) 
        over r@ < while 
            2dup r@ is-kaprekar? if 
                drop  r> drop  exit  then 
            swap  base @ *  swap 
    repeat 
    r> drop  1 = and ;

Fortran

Works with: Fortran version 95 and later
program Karpekar_Numbers
  implicit none
   
  integer, parameter :: i64 = selected_int_kind(18)
  integer :: count 
 
  call karpekar(10000_i64, .true.)
  write(*,*)
  call karpekar(1000000_i64, .false.)
  
contains

subroutine karpekar(n, printnums)

  integer(i64), intent(in) :: n
  logical, intent(in) :: printnums
  integer(i64) :: c, i, j, n1, n2
  character(19) :: str, s1, s2
  
  c = 0
  do i = 1, n
    write(str, "(i0)") i*i
    do j = 0, len_trim(str)-1
      s1 = str(1:j)
      s2 = str(j+1:len_trim(str)) 
      read(s1, "(i19)") n1
      read(s2, "(i19)") n2
      if(n2 == 0) cycle
      if(n1 + n2 == i) then
        c = c + 1
        if (printnums .eqv. .true.) write(*, "(i0)") i
        exit
      end if
    end do    
  end do
  if (printnums .eqv. .false.) write(*, "(i0)") c
end subroutine
end program
Output:
1
9
45
55
99
297
703
999
2223
2728
4879
4950
5050
5292
7272
7777
9999

54

FreeBASIC

' version 04-12-2016
' compile with: fbc -s console

' define true and false for older versions
#Ifndef TRUE
#Define FALSE 0
#Define TRUE Not FALSE
#EndIf

#Define max 1000000   ' maximum for number to be tested

Function kaprekar(n As ULong) As ULong

    If n = 1 Then Return TRUE

    Dim As ULong x, p1, p2
    Dim As ULongInt sq = CLngInt(n) * n
    Dim As String sq_str = Str(sq)
    Dim As ULong l = Len(sq_str)

    ' decrease the lenght l for every "0"
    ' at the end of the string
    For x = l -1 To 1 Step -1
        If sq_str[x] = Asc("0") Then
            l = l -1
        Else
            Exit For
        End If
    Next

    For x = 1 To l -1
        p2 = Val(Mid(sq_str, x +1))
        If p2 > n Then
            Continue For
        End If
        p1 = Val(Left(sq_str, x))
        If p1 > n Then Return FALSE  ' p1 > n leave
        If (p1 + p2) = n Then Return TRUE 
    Next

End Function

' ------=< MAIN >=------

Dim As ULong n, count

Print "Kaprekar numbers below 10000"

For n = 1 To max -1
    If kaprekar(n) = TRUE Then
        count = count + 1
        If n < 10000 Then
            Print count, n
        End If
    End If
Next

Print
Print count;" numbers below "; Str(max);" are Kaprekar numbers"

' empty keyboard buffer
While Inkey <> "" : Wend
Print : Print "hit any key to end program"
Sleep
End
Output:
Kaprekar numbers below 10000
1             1
2             9
3             45
4             55
5             99
6             297
7             703
8             999
9             2223
10            2728
11            4879
12            4950
13            5050
14            5292
15            7272
16            7777
17            9999

54 numbers below 1000000 are Kaprekar numbers

Frink

isKaprekar[n, base=10] :=
{
   if n==1
      return [1, 1, 1]

   s = base[n^2, base]
   for i=1 to length[s]-1
   {
      ls = left[s,i]
      l = parseInt[ls, base]
      rs = right[s,-i]
      r = parseInt[rs, base]
      
      if isPositive[l] and isPositive[r] and l+r == n
         return [n, s, "$ls + $rs"]
   }

   return undef
}

f = {|x| isKaprekar[x] != undef}
println[formatTable[select[1 to 9999, f], "right"]]

println[]
print[length[select[1 to 999_999, f]]]
println[" Kaprekar numbers less than 1,000,000"]

println["\nKaprekar numbers in base 17:"]
results = new array
for i = 1 to 999_999
{
   r = isKaprekar[i, 17]
   if r != undef
      results.push[r]
}
println[formatTable[results, "right"]]
Output:
   1
   9
  45
  55
  99
 297
 703
 999
2223
2728
4879
4950
5050
5292
7272
7777
9999

54 Kaprekar numbers less than 1,000,000

Kaprekar numbers in base 17:
     1         1            1
    16        f1        f + 1
    64       e2g       e + 2g
   225      a52g      a5 + 2g
   288      gf01      gf + 01
  1536    1b43b2    1b4 + 3b2
  3377    8093b2    809 + 3b2
  4912    ggf001    ggf + 001
  7425   24e166g   24e + 166g
  9280   39b1b94   39b + 1b94
 16705   b992c42   b99 + 2c42
 20736  10de32fg  10de + 32fg
 30016  23593f92  2359 + 3f92
 36801  351e433g  351e + 433g
 37440  37144382  3714 + 4382
 46081  52g94382  52g9 + 4382
 46720  5575433g  5575 + 433g
 53505  6ga43f92  6ga4 + 3f92
 62785  9a5532fg  9a55 + 32fg
 66816  aeg42c42  aeg4 + 2c42
 74241  d75f1b94  d75f + 1b94
 76096  e1f5166g  e1f5 + 166g
 83520  gggf0001  gggf + 0001
266224 a2c52a07g a2c5 + 2a07g


FutureBasic

local fn kaprekar( n as NSInteger ) as BOOL
  NSInteger s = n^2
  double t = 10^(int(log(s)) + 1)
  BOOL result = NO
  
  do
    t = t / 10
    if t <= n then break
    if s - n == int(s/t)*(t-1) then result = YES : exit fn
  until ( t <= n )
  result = ( n = YES )
end fn = result

local fn DoIt
  NSInteger i
  float n = 0
  for i = 1 to 1000000
    if ( fn kaprekar(i) )
      n++
      if i < 1000000 then printf @"%2.f : %ld", n, i
    end if
  next
  print "Kaprekar numbers under 1,000,000 = "; n
end fn

fn DoIt

HandleEvents
Output:
 1 : 1
 2 : 9
 3 : 45
 4 : 55
 5 : 99
 6 : 297
 7 : 703
 8 : 999
 9 : 2223
10 : 2728
11 : 4879
12 : 4950
13 : 5050
14 : 5292
15 : 7272
16 : 7777
17 : 9999
18 : 17344
19 : 22222
20 : 38962
21 : 77778
22 : 82656
23 : 95121
24 : 99999
25 : 142857
26 : 148149
27 : 181819
28 : 187110
29 : 208495
30 : 318682
31 : 329967
32 : 351352
33 : 356643
34 : 390313
35 : 461539
36 : 466830
37 : 499500
38 : 500500
39 : 533170
40 : 538461
41 : 609687
42 : 627615
43 : 643357
44 : 648648
45 : 670033
46 : 681318
47 : 791505
48 : 812890
49 : 818181
50 : 851851
51 : 857143
52 : 961038
53 : 994708
54 : 999999
Kaprekar numbers under 1,000,000 = �54


GAP

IsKaprekar := function(n)
	local a, b, p, q;
	if n = 1 then
		return true;
	fi;
	q := n*n;
	p := 10;
	while p < q do
		a := RemInt(q, p);
		b := QuoInt(q, p);
		if a > 0 and a + b = n then
			return true;
		fi;
		p := p*10;
	od;
	return false;
end;

Filtered([1 .. 10000], IsKaprekar);
# [ 1, 9, 45, 55, 99, 297, 703, 999, 2223, 2728, 4879, 4950, 5050, 5292, 7272, 
#   7777, 9999 ]

Size(last);
# 17

Filtered([1 .. 1000000], IsKaprekar);
# [ 1, 9, 45, 55, 99, 297, 703, 999, 2223, 2728, 4879, 4950, 5050, 5292, 7272, 
#   7777, 9999, 17344, 22222, 38962, 77778, 82656, 95121, 99999, 142857, 
#   148149, 181819, 187110, 208495, 318682, 329967, 351352, 356643, 390313, 
#   461539, 466830, 499500, 500500, 533170, 538461, 609687, 627615, 643357, 
#   648648, 670033, 681318, 791505, 812890, 818181, 851851, 857143, 961038, 
#   994708, 999999 ]

Size(last);
# 54


IsKaprekarAndHow := function(n, base)
	local a, b, p, q;
	if n = 1 then
		return true;
	fi;
	q := n*n;
	p := base;
	while p < q do
		a := RemInt(q, p);
		b := QuoInt(q, p);
		if a > 0 and a + b = n then
			return [a, b];
		fi;
		p := p*base;
	od;
	return false;
end;

IntegerToBaseRep := function(n, base)
	local s, digit;
	if base > 36 then
		return fail;
	elif n = 0 then
		return "0";
	else
		s := "";
		digit := "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ";
		while n <> 0 do
			Add(s, digit[RemInt(n, base) + 1]);
			n := QuoInt(n, base);
		od;
		return Reversed(s);
	fi;
end;

PrintIfKaprekar := function(n, base)
	local v;
	v := IsKaprekarAndHow(n, base);
	if IsList(v) then
		Print(n, "(10) or in base ", base, ", ",
			IntegerToBaseRep(n, base), "^2 = ",
			IntegerToBaseRep(n^2, base), " and ",
			IntegerToBaseRep(v[2], base), " + ",
			IntegerToBaseRep(v[1], base), " = ",
			IntegerToBaseRep(n, base), "\n");
	fi;
	return fail;
end;

# In base 17...
Perform([1 .. 1000000], n -> PrintIfKaprekar(n, 17));
# 16(10) or in base 17, G^2 = F1 and F + 1 = G
# 64(10) or in base 17, 3D^2 = E2G and E + 2G = 3D
# 225(10) or in base 17, D4^2 = A52G and A5 + 2G = D4
# 288(10) or in base 17, GG^2 = GF01 and GF + 1 = GG
# 1536(10) or in base 17, 556^2 = 1B43B2 and 1B4 + 3B2 = 556
# 3377(10) or in base 17, BBB^2 = 8093B2 and 809 + 3B2 = BBB
# 4912(10) or in base 17, GGG^2 = GGF001 and GGF + 1 = GGG
# 7425(10) or in base 17, 18BD^2 = 24E166G and 24E + 166G = 18BD
# 9280(10) or in base 17, 1F1F^2 = 39B1B94 and 39B + 1B94 = 1F1F
# 16705(10) or in base 17, 36DB^2 = B992C42 and B99 + 2C42 = 36DB
# 20736(10) or in base 17, 43CD^2 = 10DE32FG and 10DE + 32FG = 43CD
# 30016(10) or in base 17, 61EB^2 = 23593F92 and 2359 + 3F92 = 61EB
# 36801(10) or in base 17, 785D^2 = 351E433G and 351E + 433G = 785D
# 37440(10) or in base 17, 7A96^2 = 37144382 and 3714 + 4382 = 7A96
# 46081(10) or in base 17, 967B^2 = 52G94382 and 52G9 + 4382 = 967B
# 46720(10) or in base 17, 98B4^2 = 5575433G and 5575 + 433G = 98B4
# 53505(10) or in base 17, AF26^2 = 6GA43F92 and 6GA4 + 3F92 = AF26
# 62785(10) or in base 17, CD44^2 = 9A5532FG and 9A55 + 32FG = CD44
# 66816(10) or in base 17, DA36^2 = AEG42C42 and AEG4 + 2C42 = DA36
# 74241(10) or in base 17, F1F2^2 = D75F1B94 and D75F + 1B94 = F1F2
# 76096(10) or in base 17, F854^2 = E1F5166G and E1F5 + 166G = F854
# 83520(10) or in base 17, GGGG^2 = GGGF0001 and GGGF + 1 = GGGG
# 266224(10) or in base 17, 33334^2 = A2C52A07G and A2C5 + 2A07G = 33334

Go

Using the Ada interpretation of 1000000 base 17:

package main

import (
    "fmt"
    "strconv"
)

func kaprekar(n uint64, base uint64) (bool, int) {
    order := 0
    if n == 1 {
        return true, -1
    }

    nn, power := n*n, uint64(1)
    for power <= nn {
        power *= base
        order++
    }

    power /= base
    order--
    for ; power > 1; power /= base {
        q, r := nn/power, nn%power
        if q >= n {
            return false, -1
        }

        if q+r == n {
            return true, order
        }

        order--
    }

    return false, -1
}

func main() {
    max := uint64(10000)
    fmt.Printf("Kaprekar numbers < %d:\n", max)
    for m := uint64(0); m < max; m++ {
        if is, _ := kaprekar(m, 10); is {
            fmt.Println("  ", m)
        }
    }

    // extra credit
    max = 1e6
    var count int
    for m := uint64(0); m < max; m++ {
        if is, _ := kaprekar(m, 10); is {
            count++
        }
    }
    fmt.Printf("\nThere are %d Kaprekar numbers < %d.\n", count, max)

    // extra extra credit
    const base = 17
    maxB := "1000000"
    fmt.Printf("\nKaprekar numbers between 1 and %s(base %d):\n", maxB, base)
    max, _ = strconv.ParseUint(maxB, base, 64)
    fmt.Printf("\n Base 10  Base %d        Square       Split\n", base)
    for m := uint64(2); m < max; m++ {
        is, pos := kaprekar(m, base)
        if !is {
            continue
        }
        sq := strconv.FormatUint(m*m, base)
        str := strconv.FormatUint(m, base)
        split := len(sq)-pos
        fmt.Printf("%8d  %7s  %12s  %6s + %s\n", m,
            str, sq, sq[:split], sq[split:]) // optional extra extra credit
    }
}
Output:
Kaprekar numbers < 10000:
   1
   9
   45
   55
   99
   297
   703
   999
   2223
   2728
   4879
   4950
   5050
   5292
   7272
   7777
   9999

There are 54 Kaprekar numbers < 1000000.

Kaprekar numbers between 1 and 1000000(base 17):

 Base 10  Base 17        Square       Split
      16        g            f1       f + 1
      64       3d           e2g       e + 2g
     225       d4          a52g      a5 + 2g
     288       gg          gf01      gf + 01
    1536      556        1b43b2     1b4 + 3b2
    3377      bbb        8093b2     809 + 3b2
    4912      ggg        ggf001     ggf + 001
    7425     18bd       24e166g     24e + 166g
    9280     1f1f       39b1b94     39b + 1b94
   16705     36db       b992c42     b99 + 2c42
   20736     43cd      10de32fg    10de + 32fg
   30016     61eb      23593f92    2359 + 3f92
   36801     785d      351e433g    351e + 433g
   37440     7a96      37144382    3714 + 4382
   46081     967b      52g94382    52g9 + 4382
   46720     98b4      5575433g    5575 + 433g
   53505     af26      6ga43f92    6ga4 + 3f92
   62785     cd44      9a5532fg    9a55 + 32fg
   66816     da36      aeg42c42    aeg4 + 2c42
   74241     f1f2      d75f1b94    d75f + 1b94
   76096     f854      e1f5166g    e1f5 + 166g
   83520     gggg      gggf0001    gggf + 0001
  266224    33334     a2c52a07g    a2c5 + 2a07g
 1153633    ddddd    b3d5e2a07g   b3d5e + 2a07g
 1334529    fgacc    f0540f1a78    f054 + 0f1a78
 1419856    ggggg    ggggf00001   ggggf + 00001
 1787968   146fca   19g4c12dg7f   19g4c + 12dg7f
 3122497   236985   4e3be1f95d8   4e3be + 1f95d8
 3773952   2b32b3   711cb2420f9   711cb + 2420f9
 4243968   2gde03   8fegb27eg09   8fegb + 27eg09
 5108481   3a2d6f   cg10b2e3c64   cg10b + 2e3c64
 5561920   3fa16d   f5eae3043cg   f5eae + 3043cg
 6031936   443ccd  110dde332ffg  110dde + 332ffg
 6896449   4e9c28  16a10c37gb1d  16a10c + 37gb1d
 7435233   54067b  1a72g93aa382  1a72g9 + 3aa382
 8017920   5aggb6  1ef1d43d1ef2  1ef1d4 + 3d1ef2
 9223201   687534  2835c5403g7g  2835c5 + 403g7g
 9805888   6f6f6g  2dbe3f41c131  2dbe3f + 41c131
11140416   7e692a  3a997c43dgbf  3a997c + 43dgbf
11209185   7f391e  3b58d543f059  3b58d5 + 43f059
12928384   91d7f3  4ef79b43f059  4ef79b + 43f059
12997153   92a7e7  4fd82943dgbf  4fd829 + 43dgbf
14331681   a1a1a1  5gf07041c131  5gf070 + 41c131
14914368   a89bdd  685c5e403g7g  685c5e + 403g7g
16119649   b6005b  79f2793d1ef2  79f279 + 3d1ef2
16702336   bcga96  8267143aa382  826714 + 3aa382
17241120   c274e9  8b7acd37gb1d  8b7acd + 37gb1d
18105633   ccd444  99a555332ffg  99a555 + 332ffg
18575649   d16fa4  a12be53043cg  a12be5 + 3043cg
19029088   d6e3a2  a9a83f2e3c64  a9a83f + 2e3c64
19893601   e032ge  b953g527eg09  b953g5 + 27eg09
20363617   e5de5e  c1bd752420f9  c1bd75 + 2420f9
21015072   eda78c  cf11c41f95d8  cf11c4 + 1f95d8
22349601   fca147  e9d1d912dg7f  e9d1d9 + 12dg7f
22803040   g10645  f2fcde0f1a78  f2fcde + 0f1a78
24137568   gggggg  gggggf000001  gggggf + 000001

Groovy

Translation of: Java
class Kaprekar {
    private static String[] splitAt(String str, int idx) {
        String[] ans = new String[2]
        ans[0] = str.substring(0, idx)
        if (ans[0] == "") ans[0] = "0" //parsing "" throws an exception
        ans[1] = str.substring(idx)
        return ans
    }

    static void main(String[] args) {
        int count = 0
        int base = (args.length > 0) ? Integer.parseInt(args[0]) : 10
        for (long i = 1; i <= 1000000; i++) {
            String sqrStr = Long.toString(i * i, base)
            for (int j = 0; j < sqrStr.length() / 2 + 1; j++) {
                String[] parts = splitAt(sqrStr, j)
                if (parts[1] == "") continue
                long firstNum = Long.parseLong(parts[0], base)
                long secNum = Long.parseLong(parts[1], base)
                //if the right part is all zeroes, then it will be forever, so break
                if (secNum == 0) break
                if (firstNum + secNum == i) {
                    System.out.println(i + "\t" + Long.toString(i, base) + "\t" + sqrStr + "\t" + parts[0] + " + " + parts[1])
                    count++
                    break
                }
            }
        }
        System.out.println(count + " Kaprekar numbers < 1000000 (base 10) in base " + base)
    }
}
Output:
1	1	1	0 + 1
9	9	81	8 + 1
45	45	2025	20 + 25
55	55	3025	30 + 25
99	99	9801	98 + 01
297	297	88209	88 + 209
703	703	494209	494 + 209
999	999	998001	998 + 001
2223	2223	4941729	494 + 1729
2728	2728	7441984	744 + 1984
4879	4879	23804641	238 + 04641
4950	4950	24502500	2450 + 2500
5050	5050	25502500	2550 + 2500
5292	5292	28005264	28 + 005264
7272	7272	52881984	5288 + 1984
7777	7777	60481729	6048 + 1729
9999	9999	99980001	9998 + 0001
17344	17344	300814336	3008 + 14336
22222	22222	493817284	4938 + 17284
38962	38962	1518037444	1518 + 037444
77778	77778	6049417284	60494 + 17284
82656	82656	6832014336	68320 + 14336
95121	95121	9048004641	90480 + 04641
99999	99999	9999800001	99998 + 00001
142857	142857	20408122449	20408 + 122449
148149	148149	21948126201	21948 + 126201
181819	181819	33058148761	33058 + 148761
187110	187110	35010152100	35010 + 152100
208495	208495	43470165025	43470 + 165025
318682	318682	101558217124	101558 + 217124
329967	329967	108878221089	108878 + 221089
351352	351352	123448227904	123448 + 227904
356643	356643	127194229449	127194 + 229449
390313	390313	152344237969	152344 + 237969
461539	461539	213018248521	213018 + 248521
466830	466830	217930248900	217930 + 248900
499500	499500	249500250000	249500 + 250000
500500	500500	250500250000	250500 + 250000
533170	533170	284270248900	284270 + 248900
538461	538461	289940248521	289940 + 248521
609687	609687	371718237969	371718 + 237969
627615	627615	393900588225	39390 + 0588225
643357	643357	413908229449	413908 + 229449
648648	648648	420744227904	420744 + 227904
670033	670033	448944221089	448944 + 221089
681318	681318	464194217124	464194 + 217124
791505	791505	626480165025	626480 + 165025
812890	812890	660790152100	660790 + 152100
818181	818181	669420148761	669420 + 148761
851851	851851	725650126201	725650 + 126201
857143	857143	734694122449	734694 + 122449
961038	961038	923594037444	923594 + 037444
994708	994708	989444005264	989444 + 005264
999999	999999	999998000001	999998 + 000001
54 Kaprekar numbers < 1000000 (base 10) in base 10

Haskell

import Text.Printf (printf)
import Data.Maybe (mapMaybe)
import Numeric (showIntAtBase)

kaprekars :: Integer -> Integer -> [(Integer, Integer, Integer)]
kaprekars base top = (1, 0, 1) : mapMaybe kap (filter res [2 .. top])
  where
    res x = x * (x - 1) `mod` (base - 1) == 0
    kap n =
      getSplit $
      takeWhile (<= nn) $ dropWhile (< n) $ iterate (* toInteger base) 1
      where
        nn = n * n
        getSplit [] = Nothing
        getSplit (p:ps)
          | p == n = Nothing
          | q + r == n = Just (n, q, r)
          | r > n = Nothing
          | otherwise = getSplit ps
          where
            (q, r) = nn `divMod` p

heading :: Int -> String
heading = printf (h ++ d)
  where
    h = " #    Value (base 10)         Sum (base %d)             Square\n"
    d = " -    ---------------         -------------             ------"

printKap :: Integer -> (Int, (Integer, Integer, Integer)) -> String
printKap b (i, (n, l, r)) =
  printf "%2d %13s %26s %16s" i (show n) ss (base b (n * n))
  where
    ss = base b n ++ " = " ++ base b l ++ " + " ++ base b r
    base b n = showIntAtBase b (("0123456789" ++ ['a' .. 'z']) !!) n ""

main :: IO ()
main = do
  putStrLn $ heading 10
  mapM_ (putStrLn . printKap 10) $ zip [1 ..] (kaprekars 10 1000000)
  putStrLn ""
  putStrLn $ heading 17
  mapM_ (putStrLn . printKap 17) $ zip [1 ..] (kaprekars 17 1000000)
Output:
 #    Value (base 10)         Sum (base 10)             Square
 -    ---------------         -------------             ------

 1             1                       1 = 1 + 0                1
 2             9                       9 = 8 + 1               81
 3            45                    45 = 20 + 25             2025
 4            55                    55 = 30 + 25             3025
 5            99                     99 = 98 + 1             9801
 6           297                  297 = 88 + 209            88209
 7           703                 703 = 494 + 209           494209
 8           999                   999 = 998 + 1           998001
 9          2223               2223 = 494 + 1729          4941729
10          2728               2728 = 744 + 1984          7441984
11          4879               4879 = 238 + 4641         23804641
12          4950              4950 = 2450 + 2500         24502500
13          5050              5050 = 2550 + 2500         25502500
14          5292                5292 = 28 + 5264         28005264
15          7272              7272 = 5288 + 1984         52881984
16          7777              7777 = 6048 + 1729         60481729
17          9999                 9999 = 9998 + 1         99980001
18         17344            17344 = 3008 + 14336        300814336
19         22222            22222 = 4938 + 17284        493817284
20         38962            38962 = 1518 + 37444       1518037444
21         77778           77778 = 60494 + 17284       6049417284
22         82656           82656 = 68320 + 14336       6832014336
23         95121            95121 = 90480 + 4641       9048004641
24         99999               99999 = 99998 + 1       9999800001
                      .
                      .
                      .
51        857143        857143 = 734694 + 122449     734694122449
52        961038         961038 = 923594 + 37444     923594037444
53        994708          994708 = 989444 + 5264     989444005264
54        999999             999999 = 999998 + 1     999998000001

 #    Value (base 10)         Sum (base 17)             Square
 -    ---------------         -------------             ------

 1             1                       1 = 1 + 0                1
 2            16                       g = f + 1               f1
 3            64                     3d = e + 2g              e2g
 4           225                    d4 = a5 + 2g             a52g
 5           288                     gg = gf + 1             gf01
                      .
                      .
                      .
21         74241              f1f2 = d75f + 1b94         d75f1b94
22         76096              f854 = e1f5 + 166g         e1f5166g
23         83520                 gggg = gggf + 1         gggf0001
24        266224            33334 = a2c5 + 2a07g        a2c52a07g

Generating Kaprekar numbers by factorizing b^n - 1:

import Control.Monad (foldM, join)
import Data.List (group, nub, sort)

primes :: [Int]
primes = 2 : 3 : filter isPrime (scanl (+) 5 $ cycle [2, 4])
  where
    isPrime x = all ((0 /=) . mod x) $ takeWhile ((<= x) . join (*)) primes

unitFactors :: Int -> [Int]
unitFactors n = map product $ group $ f n $ takeWhile ((<= n) . join (*)) primes
  where
    f 1 [] = []
    f n [] = [n]
    f n (p:ps)
      | n `mod` p == 0 = p : f (n `div` p) (p : ps)
      | otherwise = f n ps

-- all factors x of n where x and n/x are coprime
factors :: Int -> [Int]
factors = foldM f 1 . unitFactors
  where
    f x a = [x, x * a]

-- modulo multiplication inverse: returns a where a x + b y == 1
inverse :: Int -> Int -> Int
inverse x y =
  if a < 0
    then a + y
    else a
  where
    (a, b) = extEuclid x y
    extEuclid _ 0 = (1, 0)
    extEuclid x y = (t, s - q * t)
      where
        (s, t) = extEuclid y r
        (q, r) = x `divMod` y

kaprekars :: Int -> Int -> [Int]
kaprekars base top =
  nub . sort . concatMap kaps $
  takeWhile (<= top * top `div` base ^ 2) $ (\x -> base ^ x - 1) <$> [1 ..]
  where
    kaps pb = filter (<= top) $ f <$> factors pb
      where
        f x
          | x == pb = pb
          | otherwise = x * inverse x (pb `div` x)

main :: IO ()
main = mapM_ print $ kaprekars 10 10000000

Icon and Unicon

procedure is_kaprekar(n)  #: return n if n is a kaprekar number
if ( n = 1 ) |
   ( n^2 ? ( n = move(1 to *&subject-1) + (0 ~= tab(0)) | fail )) then
   return n 
end

procedure main()
every write(is_kaprekar(1 to 10000))                        # primary goal
every (count := 0, is_kaprekar(1 to 999999), count +:= 1)   # stretch goal
write ("Number of Kaprekar numbers less than 1000000 is ", count)
end
Output:
1
9
45
55
99
297
703
999
2223
2728
4879
4950
5050
5292
7272
7777
9999
Number of Kaprekar numbers less than 1000000 is 54

J

Solution:

kapbase=: 0,. [ ^ 1 + [: i. 1 + [ <.@^.  >.&1
isKap=: 1 e. ] ((0 < {:"1@]) *. [ = +/"1@]) kapbase #: *:@]

Example use:

   I. 10 isKap"0 i.1e6
1 9 45 55 99 297 703 999 2223 2728 4879 4950 5050 5292 7272 7777 9999 17344 22222 38962 77778 82656 95121 99999 142857 148149 181819 187110 208495 318682 329967 351352 356643 390313 461539 466830 499500 500500 533170 538461 609687 627615 643357 648648 670033 681318 791505 812890 818181 851851 857143 961038 994708 999999

"Extra credit": (text representing numbers left in boxes for alignment purposes)

   ]K17=: I. 17 isKap"0 i.1e6
1 16 64 225 288 1536 3377 4912 7425 9280 16705 20736 30016 36801 37440 46081 46720 53505 62785 66816 74241 76096 83520 266224
   base=: [: (] u:@+ 39 * 57 < ]) 48 + #.inv 
   17 ([ base&.> ],*:@],] (] {:@,@#~ (0 < {:"1@]) *. [ = +/"1@]) kapbase #: *:@])"0 x:K17
┌─────┬─────────┬─────┐
1    1        1    
├─────┼─────────┼─────┤
g    f1       1    
├─────┼─────────┼─────┤
3d   e2g      2g   
├─────┼─────────┼─────┤
d4   a52g     2g   
├─────┼─────────┼─────┤
gg   gf01     1    
├─────┼─────────┼─────┤
556  1b43b2   3b2  
├─────┼─────────┼─────┤
bbb  8093b2   3b2  
├─────┼─────────┼─────┤
ggg  ggf001   1    
├─────┼─────────┼─────┤
18bd 24e166g  166g 
├─────┼─────────┼─────┤
1f1f 39b1b94  1b94 
├─────┼─────────┼─────┤
36db b992c42  2c42 
├─────┼─────────┼─────┤
43cd 10de32fg 32fg 
├─────┼─────────┼─────┤
61eb 23593f92 3f92 
├─────┼─────────┼─────┤
785d 351e433g 433g 
├─────┼─────────┼─────┤
7a96 37144382 4382 
├─────┼─────────┼─────┤
967b 52g94382 4382 
├─────┼─────────┼─────┤
98b4 5575433g 433g 
├─────┼─────────┼─────┤
af26 6ga43f92 3f92 
├─────┼─────────┼─────┤
cd44 9a5532fg 32fg 
├─────┼─────────┼─────┤
da36 aeg42c42 2c42 
├─────┼─────────┼─────┤
f1f2 d75f1b94 1b94 
├─────┼─────────┼─────┤
f854 e1f5166g 166g 
├─────┼─────────┼─────┤
gggg gggf0001 1    
├─────┼─────────┼─────┤
33334a2c52a07g2a07g│
└─────┴─────────┴─────┘

The fastest times can be obtained by two optimizations: first, partitions with over half of the digits on the left (i.e. more than 3 for a 5-digit number) will not be considered because the left half is mathematically guaranteed to be greater than the original number in this case. Second, the numbers are computed in groups corresponding to the number of digits in their squares to allow isKap to be computed at full rank. Note that this method excludes 1, so it must be added manually to the list of solutions.

   kapbase=: 0,.10 ^ [: (<.+i.@>.)@(-:&.<:) 10 <.@^.  >.&1
   isKapGroup=: [: +./"1 (((0 < {:"1@]) *. [ = +/"1@]) (kapbase@{: #:"2 0 ])@:*:)
   6!:2 'a=.1, I. ([:; (<@isKapGroup/.~ 10<.@^.*:)) i.1e6'
12.3963
   #a
54

Alternative solution: The following is a more naive, mechanical solution

splitNum=: {. ,&(_&".) }.
allSplits=: (i.&.<:@# splitNum"0 1 ])@":
sumValidSplits=: +/"1@:(#~ 0 -.@e."1 ])
filterKaprekar=: #~ ] e."0 1 [: sumValidSplits@allSplits"0 *:

Example use:

   filterKaprekar i. 10000
0 9 45 55 99 297 703 999 2223 2728 4879 4950 5050 5292 7272 7777 9999
   #filterKaprekar i. 1e6
54

Java

public class Kaprekar {
    private static String[] splitAt(String str, int idx){
        String[] ans = new String[2];
        ans[0] = str.substring(0, idx);
        if(ans[0].equals("")) ans[0] = "0"; //parsing "" throws an exception
        ans[1] = str.substring(idx);
        return ans;
    }
        
    public static void main(String[] args){
        int count = 0;
        int base = (args.length > 0) ? Integer.parseInt(args[0]) : 10;
        for(long i = 1; i <= 1000000; i++){
            String sqrStr = Long.toString(i * i, base);
            for(int j = 0; j < sqrStr.length() / 2 + 1; j++){
                String[] parts = splitAt(sqrStr, j);
                long firstNum = Long.parseLong(parts[0], base);
                long secNum = Long.parseLong(parts[1], base);
                //if the right part is all zeroes, then it will be forever, so break
                if(secNum == 0) break;
                if(firstNum + secNum == i){
                    System.out.println(i + "\t" + Long.toString(i, base) +
                            "\t" + sqrStr + "\t" + parts[0] + " + " + parts[1]);
                    count++;
                    break;
                }
            }
        }
        System.out.println(count + " Kaprekar numbers < 1000000 (base 10) in base "+base);
    }
}
Output:
(base 10, shortened)
1	1	1	0 + 1
9	9	81	8 + 1
45	45	2025	20 + 25
55	55	3025	30 + 25
99	99	9801	98 + 01
297	297	88209	88 + 209
703	703	494209	494 + 209
999	999	998001	998 + 001
2223	2223	4941729	494 + 1729
2728	2728	7441984	744 + 1984
4879	4879	23804641	238 + 04641
4950	4950	24502500	2450 + 2500
5050	5050	25502500	2550 + 2500
5292	5292	28005264	28 + 005264
7272	7272	52881984	5288 + 1984
7777	7777	60481729	6048 + 1729
9999	9999	99980001	9998 + 0001
...
818181	818181	669420148761	669420 + 148761
851851	851851	725650126201	725650 + 126201
857143	857143	734694122449	734694 + 122449
961038	961038	923594037444	923594 + 037444
994708	994708	989444005264	989444 + 005264
999999	999999	999998000001	999998 + 000001
54 Kaprekar numbers < 1000000 (base 10) in base 10
Output:
(base 17, shortened)
1	1	1	0 + 1
16	g	f1	f + 1
64	3d	e2g	e + 2g
225	d4	a52g	a5 + 2g
288	gg	gf01	gf + 01
1536	556	1b43b2	1b4 + 3b2
3377	bbb	8093b2	809 + 3b2
4912	ggg	ggf001	ggf + 001
7425	18bd	24e166g	24e + 166g
9280	1f1f	39b1b94	39b + 1b94
...
76096	f854	e1f5166g	e1f5 + 166g
83520	gggg	gggf0001	gggf + 0001
266224	33334	a2c52a07g	a2c5 + 2a07g
24 Kaprekar numbers < 1000000 (base 10) in base 17

JavaScript

This string version

function isKaprekar( n, bs ) {
	if ( n < 1 ) return false
	if ( n == 1 ) return true
	bs = bs || 10
	var s = (n * n).toString(bs)
	for (var i=1, e=s.length; i<e; i+=1) {
		var a = parseInt(s.substr(0, i), bs)
		var b = parseInt(s.substr(i), bs)
		if (b && a + b == n) return true
	}
	return false
}

or this numeric version

function isKaprekar( n, bs ) {
	if ( n < 1 ) return false
	if ( n == 1 ) return true
	bs = bs || 10
	for (var a=n*n, b=0, s=1; a; s*=bs) {
		b += a%bs*s
		a = Math.floor(a/bs)
		if (b && a + b == n) return true
	}
	return false
}

with

function kaprekar( s, e, bs, pbs ) {
	bs = bs || 10; pbs = pbs || 10
	const toString = n => n.toString(pbs).toUpperCase()
	document.write('start:',toString(s), ' end:',toString(e), ' base:',bs, ' printBase:',pbs, '<br>' )
	for (var k=0, n=s; n<=e; n+=1) if (isKaprekar(n, bs)) k+=1, document.write(toString(n), ' ') 
	document.write('<br>found ', k, ' numbers<br><br>')
}

kaprekar( 1, 99 )
kaprekar( 1, 255, 16)
kaprekar( 1, 255, 16, 16)
kaprekar( 1, 288, 17, 17)
Output:
start:1 end:99 base:10 printBase:10
1 9 45 55 99
found 5 numbers

start:1 end:255 base:16 printBase:10
1 6 10 15 51 85 91 120 136 171 205 255
found 12 numbers

start:1 end:FF base:16 printBase:16
1 6 A F 33 55 5B 78 88 AB CD FF
found 12 numbers

start:1 end:GG base:17 printBase:17
1 G 3D D4 GG
found 5 numbers

jq

Works with: jq version 1.4
# Is the input integer a Kaprekar integer?
def is_kaprekar:
    # The helper function acts like a loop:
    # input is [n, number, str]
    # where n is the position to be considered next,
    # number is the integer under consideration,
    # and str is the string representing number*number
    def _try:  
      .[0] as $n | .[1] as $number | .[2] as $str
      | if $n >= ($str|length) then null
        else   ($str[0:$n] | tonumber) as $left
             | ($str[$n:]  | tonumber) as $right
             | if $left > $number then null
               elif $right == 0 then null
               elif ($left + $right) == $number then $n
               else [($n + 1), $number, $str] | _try
               end
        end;
    . as $in
    | if . == 1 then true
      elif . < 1 then false
      else null != ([1, $in, ($in*$in|tostring)] | _try)
      end ;

# Useful for counting how many times the condition is satisfied:
def count(generator; condition):
  reduce generator as $i (0; if ($i|condition ) then .+1 else . end);

def task:
  [ range(1;10000) | select( is_kaprekar ) ],
  count( range(1;1000000); is_kaprekar )
;
Output:
$ jq -n -c -f is_kaprekar.jq
[1,9,45,55,99,297,703,999,2223,2728,4879,4950,5050,5292,7272,7777,9999]
54

Julia

Works with: Julia version 1.2
function iskaprekar(n::Integer)
    n == 1 && return true
    test(a, b) = n == a + b && b  0
    str = string(n^2)
    any(test(parse(Int, str[1:i]), parse(Int, str[i+1:end])) for i = 1:length(str)-1)
end

@show filter(iskaprekar, 1:10000)
@show count(iskaprekar, 1:10000)
Output:
filter(iskaprekar, 1:10000) = [1, 9, 45, 55, 99, 297, 703, 999, 2223, 2728, 4879, 4950, 5050, 5292, 7272, 7777, 9999]
count(iskaprekar, 1:10000) = 17

Kotlin

Translation of: Java
import java.lang.Long.parseLong
import java.lang.Long.toString

fun String.splitAt(idx: Int): Array<String> {
    val ans = arrayOf(substring(0, idx), substring(idx))
    if (ans.first() == "") ans[0] = "0" // parsing "" throws an exception
    return ans
}

fun Long.getKaprekarParts(sqrStr:  String, base: Int): Array<String>? {
    for (j in 0..sqrStr.length / 2) {
        val parts = sqrStr.splitAt(j)
        val (first, second) = parts.map { parseLong(it, base) }

        // if the right part is all zeroes, then it will be forever, so break
        if (second == 0L) return null
        if (first + second == this) return parts
    }
    return null
}

fun main(args: Array<String>) {
    val base = if (args.isNotEmpty()) args[0].toInt() else 10
    var count = 0
    val max = 1000000L
    for (i in 1..max) {
        val s = toString(i * i, base)
        val p = i.getKaprekarParts(s, base)
        if (p != null) {
            println("%6d\t%6s\t%12s\t%7s + %7s".format(i, toString(i, base), s, p[0], p[1]))
            count++
        }
    }
    println("$count Kaprekar numbers < $max (base 10) in base $base")
}
Output:
     1	     1	           1	      0 +       1
     9	     9	          81	      8 +       1
    45	    45	        2025	     20 +      25
    55	    55	        3025	     30 +      25
    99	    99	        9801	     98 +      01
   297	   297	       88209	     88 +     209
   703	   703	      494209	    494 +     209
   999	   999	      998001	    998 +     001
  2223	  2223	     4941729	    494 +    1729
  2728	  2728	     7441984	    744 +    1984
  4879	  4879	    23804641	    238 +   04641
  4950	  4950	    24502500	   2450 +    2500
  5050	  5050	    25502500	   2550 +    2500
  5292	  5292	    28005264	     28 +  005264
  7272	  7272	    52881984	   5288 +    1984
  7777	  7777	    60481729	   6048 +    1729
  9999	  9999	    99980001	   9998 +    0001
 17344	 17344	   300814336	   3008 +   14336
 22222	 22222	   493817284	   4938 +   17284
 38962	 38962	  1518037444	   1518 +  037444
 77778	 77778	  6049417284	  60494 +   17284
 82656	 82656	  6832014336	  68320 +   14336
 95121	 95121	  9048004641	  90480 +   04641
 99999	 99999	  9999800001	  99998 +   00001
142857	142857	 20408122449	  20408 +  122449
148149	148149	 21948126201	  21948 +  126201
181819	181819	 33058148761	  33058 +  148761
187110	187110	 35010152100	  35010 +  152100
208495	208495	 43470165025	  43470 +  165025
318682	318682	101558217124	 101558 +  217124
329967	329967	108878221089	 108878 +  221089
351352	351352	123448227904	 123448 +  227904
356643	356643	127194229449	 127194 +  229449
390313	390313	152344237969	 152344 +  237969
461539	461539	213018248521	 213018 +  248521
466830	466830	217930248900	 217930 +  248900
499500	499500	249500250000	 249500 +  250000
500500	500500	250500250000	 250500 +  250000
533170	533170	284270248900	 284270 +  248900
538461	538461	289940248521	 289940 +  248521
609687	609687	371718237969	 371718 +  237969
627615	627615	393900588225	  39390 + 0588225
643357	643357	413908229449	 413908 +  229449
648648	648648	420744227904	 420744 +  227904
670033	670033	448944221089	 448944 +  221089
681318	681318	464194217124	 464194 +  217124
791505	791505	626480165025	 626480 +  165025
812890	812890	660790152100	 660790 +  152100
818181	818181	669420148761	 669420 +  148761
851851	851851	725650126201	 725650 +  126201
857143	857143	734694122449	 734694 +  122449
961038	961038	923594037444	 923594 +  037444
994708	994708	989444005264	 989444 +  005264
999999	999999	999998000001	 999998 +  000001
54 Kaprekar numbers < 1000000 (base 10) in base 10

Liberty BASIC

 
 For i = 1 To 10000  '1000000 - Changing to one million takes a long time to complete!!!!
    Kaprekar = isKaprekar(i)
    If Kaprekar Then numKaprekar = (numKaprekar + 1) : Print Kaprekar
Next i

Print numKaprekar
End

Function isKaprekar(num)
    If num < 1 Then isKaprekar = 0 : Exit Function
    If num = 1 Then isKaprekar = num : Exit Function
    squarenum$ = str$(num ^ 2)
    For i = 1 To Len(squarenum$)
        If Val(Mid$(squarenum$, i)) = 0 Then isKaprekar = 0 : Exit Function
        If (Val(Left$(squarenum$, (i - 1))) + Val(Mid$(squarenum$, i)) = num) Then isKaprekar = num : Exit Function
    Next i
End Function

Lua

-- Return length of an integer without string conversion
function numLength (n)
    local length = 0
    repeat
        n = math.floor(n / 10)
        length = length + 1
    until n == 0
    return length
end

-- Return a boolean indicating whether n is a Kaprekar number
function isKaprekar (n)
    if n == 1 then return true end
    local nSquared, a, b = n * n
    for splitPoint = 1, numLength(nSquared) - 1 do
        a = math.floor(nSquared / 10^splitPoint)
        b = nSquared % 10^splitPoint
        if a > 0 and b > 0 and a + b == n then return true end
    end
    return false
end

-- Main task
for n = 1, 10^4 do
    if isKaprekar(n) then io.write(n .. " ") end
end
 
-- Extra credit
local count = 0
for n = 1, 10^6 do
    if isKaprekar(n) then count = count + 1 end
end
print("\nThere are " .. count .. " Kaprekar numbers under one million.")
Output:
1 9 45 55 99 297 703 999 2223 2728 4879 4950 5050 5292 7272 7777 9999
There are 54 Kaprekar numbers under one million.

Maple

For a number x to be Kaprekar, it must have x^2 congruent to x mod 9. Which is only achievable when x has remainder 1 or 0 mod 9. So we only check for these cases.

isKaprekar := proc(n::posint) 
local holder, square, num_of_digits, k, left, right;
holder := true;
if n = 1 then 
 holder := true; 
else 
 holder := false; 
 square := n^2; 
 num_of_digits := length(n^2); 
 for k to num_of_digits do left := floor(square/10^k); 
     right := irem(square, 10^k); 
     if left + right = n and right <> 0 then 
        holder := true; 
     break; 
     end if; 
 end do; 
end if;
return holder; 
end proc;

showKaprekar := n -> select(isKaprekar, select(x -> irem(x, 9) = 1 or irem(x, 9) = 0, [seq(1 .. n - 1)]));

countKaprekar := n -> nops(showKaprekar(n));

showKaprekar(10000);
countKaprekar(1000000);
Output:
[1, 9, 45, 55, 99, 297, 703, 999, 2223, 2728, 4879, 4950, 5050, 5292, 7272, 7777, 9999]
54

Mathematica/Wolfram Language

KaprekaQ[1] = True;
KaprekaQ[n_Integer] :=  Block[{data = IntegerDigits[n^2], last = False, i = 1},
  While[i < Length[data] && FromDigits[data[[i + 1 ;;]]] =!= 0 &&  Not[last],
   last = FromDigits[data[[;; i]]] + FromDigits[data[[i + 1 ;;]]] == n;
   i++]; last];
Select[Range[10000], KaprekaQ]
Length[Select[Range[1000000], KaprekaQ]]
Output:
{1, 9, 45, 55, 99, 297, 703, 999, 2223, 2728, 4879, 4950, 5050, 5292, 7272, 7777, 9999}
54

Maxima

kaprekarp(n) := block(
   [p, q, a, b],
   if n = 1 then true else (
      q: n * n,
      p: 10,
      catch(
         while p < q do (
            [a, b]: divide(q, p),
            if b > 0 and a + b = n then throw(true),
            p: 10 * p
         ),
         false
      )
   )
)$

sublist(makelist(i, i, 1, 10^6), kaprekarp);
[1, 9, 45, 55, 99, 297, 703, 999, 2223, 2728, 4879, 4950, 5050, 5292, 7272, 7777, 9999,
17344, 22222, 38962, 77778, 82656, 95121, 99999, 142857, 148149, 181819, 187110, 208495,
318682, 329967, 351352, 356643, 390313, 461539, 466830, 499500, 500500, 533170, 538461,
609687, 627615, 643357, 648648, 670033, 681318, 791505, 812890, 818181, 851851, 857143,
961038, 994708, 999999]

length(%);
54

ML

mLite

local 
  val base = 10;
  fun kaprekar
        (num, numSquared, numDiv, numRem, power) where (base ^ power >= numSquared) = ()

    |   (num, numSquared, numDiv, numRem, power) where ((numDiv = 0) or (numRem = 0))= 
          kaprekar (num, numSquared, numSquared div (base ^ power ), numSquared rem (base ^ power), power + 1)

    |   (num, numSquared, numDiv, numRem, power) = 
          if ((numDiv + numRem) = num) then
            num
          else
            kaprekar (num, numSquared, numSquared div (base ^ power ), numSquared rem (base ^ power), power + 1)

    |   num = 
          if (num = 1) then
            num
          else
            kaprekar (num, num * num, (num * num) div base, (num * num) rem base, 1)
        
in
  fun kaprekar_list
       ([], collector) = rev collector
    |  (num :: nums, collector ) = 
         let
           val k = kaprekar num
         in 
           if (k = ()) then
             kaprekar_list (nums, collector)
           else
             kaprekar_list (nums, num :: collector)
         end
    |  (num :: nums) = kaprekar_list (num :: nums, []) 
end
;

Generate and show all Kaprekar numbers less than 10,000.

print "kaprekar numbers < 10_000: "; println ` kaprekar_list (iota 10000);

Optionally, count (and report the count of) how many Kaprekar numbers are less than 1,000,000.

print "number of kaprekar numbers < 1_000_000: "; println ` len ` kaprekar_list (iota 1000000);

Output:

kaprekar numbers < 10_000: [1, 9, 45, 55, 99, 297, 703, 999, 2223, 2728, 4879, 4950, 5050, 5292, 7272, 7777, 9999]
number of kaprekar numbers < 1_000_000: 54

Modula-2

MODULE Kaprekar;
FROM FormatString IMPORT FormatString;
FROM Terminal IMPORT Write,WriteString,WriteLn,ReadChar;

PROCEDURE kaprekar(n,base : LONGCARD) : BOOLEAN;
VAR
    nn,r,tens : LONGCARD;
BEGIN
    nn := n*n;
    tens := 1;
    IF ((nn - n) MOD (base - 1)) # 0 THEN RETURN FALSE END;

    WHILE tens < n DO tens := tens * base END;
    IF n = tens THEN
        IF 1 = n THEN RETURN TRUE END;
        RETURN FALSE
    END;

    LOOP
        r := nn MOD tens;
        IF r >= n THEN BREAK END;
        IF nn DIV tens + r = n THEN RETURN tens#0 END;
        tens := tens * base;
    END;

    RETURN FALSE
END kaprekar;

PROCEDURE print_num(n,base : LONGCARD);
VAR q,d : LONGCARD;
BEGIN
    d := base;

    WHILE d<n DO d := d * base END;
    LOOP
        d := d DIV base;
        IF n BAND d = 0 THEN RETURN END;
        q := n DIV d;
        IF q<10 THEN
            Write(CHR(INT(q) + INT(ORD('0'))))
        ELSE
            Write(CHR(INT(q) + INT(ORD('a')) - 10))
        END;
        n := n - q * d
    END
END print_num;

VAR
    buf : ARRAY[0..63] OF CHAR;
    i,tens,cnt,base : LONGCARD;
BEGIN
    cnt := 0;
    base := 10;
    FOR i:=1 TO 1000000 DO
        IF kaprekar(i,base) THEN
            INC(cnt);
            FormatString("%3u: %u\n", buf, cnt, i);
            WriteString(buf)
        END
    END;

    ReadChar
END Kaprekar.

Nim

import strutils, sequtils
 
proc k(n: int): bool =
  let n2 = $(n.int64 * n)
  for i in 0 .. n2.high:
    let a = if i > 0: parseBiggestInt n2[0 ..< i] else: 0
    let b = parseBiggestInt n2[i .. n2.high]
    if b > 0 and a + b == n:
      return true
 
echo toSeq(1..10_000).filter(k)
echo len toSeq(1..1_000_000).filter(k)
Output:
[1, 9, 45, 55, 99, 297, 703, 999, 2223, 2728, 4879, 4950, 5050, 5292, 7272, 7777, 9999]
54

PARI/GP

K(d)={
  my(D=10^d,DD,t,v=List());
  for(n=D/10+1,D-1,
    t=divrem(n^2,D);
    if(t[2]&t[1]+t[2]==n,listput(v,n);next);
    DD=D;
    while(t[2]<n,
      t=divrem(n^2,DD*=10);
      if(t[2]&t[1]+t[2]==n,listput(v,n);next(2))
    );
    DD=D;
    while(t[1]<n,
      t=divrem(n^2,DD/=10);
      if(t[2]&t[1]+t[2]==n,listput(v,n);next(2))
    )
  );
  Vec(v)
};
upTo(d)=my(v=[1]);for(n=1,d,v=concat(v,K(n)));v;
upTo(4)
v=upTo(6);v
#v
Output:
%1 = [1, 9, 45, 55, 99, 297, 703, 999, 2223, 2728, 4879, 4950, 5050, 5292, 7272, 7777, 9999]

%2 = [1, 9, 45, 55, 99, 297, 703, 999, 2223, 2728, 4879, 4950, 5050, 5292, 7272, 7777, 9999, 17344, 22222, 38962, 77778, 82656, 95121, 99999, 142857, 148149, 181819, 187110, 208495, 318682, 329967, 351352, 356643, 390313, 461539, 466830, 499500, 500500, 533170, 538461, 609687, 627615, 643357, 648648, 670033, 681318, 791505, 812890, 818181, 851851, 857143, 961038, 994708, 999999]

%3 = 54

Perl

Numeric with casting out nines (fast)

sub isKap {
  my $k = shift;
  return if $k*($k-1) % 9;  # Fast return "casting out nines"
  my($k2, $p) = ($k*$k, 10);
  do {
    my $i = int($k2/$p);
    my $j = $k2 % $p;
    return 1 if $j && $i+$j == $k;
    $p *= 10;
  } while $p <= $k2;
  0;
}

print "[", join(" ", grep { isKap($_) } 1..9999), "]\n\n";
my @kaprekar;
isKap($_) && push @kaprekar,$_ for 1..1_000_000;
print "Kaprekar Numbers below 1000000: ", scalar(@kaprekar), "\n";
Output:
[1 9 45 55 99 297 703 999 2223 2728 4879 4950 5050 5292 7272 7777 9999]

Kaprekar Numbers below 1000000: 54

Iannucci factoring method (extremely fast)

We can also use the method of Douglas Iannucci to get much faster results (the below takes only a few milliseconds). This works for bigints as well.

Library: ntheory
use ntheory qw/fordivisors gcd invmod/;

my %kap;
for my $n (1..15) {
  my $np = int(10**$n)-1;
  fordivisors {
    my($d, $dp) = ($_, $np/$_);
    $kap{ $dp==1 ? $d : invmod($d,$dp)*$d }++
      if  gcd($d, $dp) == 1;
  } $np;
}
my @kap = sort { $a<=>$b } keys %kap;
for my $n (6 .. 14) {
  my $np = int(10**$n)-1;
  printf "Kaprekar numbers <= 10^%2d:  %5d\n",
         $n, scalar(grep { $_ <= $np } @kap);
}
Output:
Kaprekar numbers <= 10^ 6:     54
Kaprekar numbers <= 10^ 7:     62
Kaprekar numbers <= 10^ 8:     91
Kaprekar numbers <= 10^ 9:    102
Kaprekar numbers <= 10^10:    132
Kaprekar numbers <= 10^11:    149
Kaprekar numbers <= 10^12:    264
Kaprekar numbers <= 10^13:    281
Kaprekar numbers <= 10^14:    316

Phix

with javascript_semantics
atom r, l
function Kaprekar(integer n, base=10)
    if n=1 then return true end if
    atom sq=n*n, basen = base
    r=0
    while r<n do
        r = mod(sq,basen)
        l = floor(sq/basen)
        if r and l and l+r=n then return true end if
        basen *= base
    end while
    return false
end function
 
sequence s = {}
for i=1 to 10_000 do
    if Kaprekar(i) then
        s &= i
    end if
end for
printf(1,"There are %d Kaprekar numbers between 1 and 10,000:\n%v\n",{length(s),s})
integer c = 0
for i=1 to 1_000_000 do
    c += Kaprekar(i)
end for
printf(1,"There are %d Kaprekar numbers between 1 and 1,000,000\n",c)
 
function base17(sequence s)
    s = deep_copy(s)
    for i=1 to length(s) do
        atom si = s[i]
        string num = ""
        while si do
            integer digit = mod(si,17)
            si = floor(si/17)
            num = digit+iff(digit<=9?'0':87)&num
        end while
        s[i] = num
    end for
    return s
end function
 
s = {} r = 1 l = 1
for i=1 to 1_000_000 do
    if Kaprekar(i,17) then
        s = append(s,{i,i*i,l,r})
    end if
end for
printf(1,"There are %d Kaprekar base 17 numbers between 1 and 1,000,000 (decimal):\n",length(s))
s[5..-5] = {}
for i=1 to length(s) do
    printf(1,"%s squared %s, split %s+%s\n",base17(s[i]))
    if i=4 then printf(1," ...\n") end if
end for
Output:
There are 17 Kaprekar numbers between 1 and 10,000:
{1,9,45,55,99,297,703,999,2223,2728,4879,4950,5050,5292,7272,7777,9999}
There are 54 Kaprekar numbers between 1 and 1,000,000
There are 24 Kaprekar base 17 numbers between 1 and 1,000,000 (decimal):
1 squared 1, split 1+1
g squared f1, split f+1
3d squared e2g, split e+2g
d4 squared a52g, split a5+2g
 ...
f1f2 squared d75f1b94, split d75f+1b94
f854 squared e1f5166g, split e1f5+166g
gggg squared gggf0001, split gggf+1
33334 squared a2c52a07g, split a2c5+2a07g

Phixmonti

def FNkaprekar
    var n
    dup 2 power var s
    s log int 1 + 10 swap power var t
    true while
        t 10 / var t
        t n <= IF false else
            s n - s t / int t 1 - * == IF false 1 var n else TRUE endif
        endif
    endwhile
    n 1 ==
enddef

0
10000 FOR
     dup FNkaprekar IF print " " print 1 + else drop endif
endfor
nl print " Kaprekar numbers" print

PHP

set_time_limit(300);

print_r(array_filter(range(1, 10000), 'isKaprekar'));
echo count(array_filter(range(1, 1000000), 'isKaprekar'));

function isKaprekar($n) {
    $a = $n * $n; 
    $b = bcmod("$a", "10");
    for ($d = 1, $t = 0; $a > 0; $d *= 10) {
        $b += $t * $d;
        if ($b > $n) break;
        $a = floor($a / 10);
        if ($b && $a + $b == $n) 
            return true;
        $t = bcmod("$a", "10");
    }
    return false;
}
Array
(
    [0] => 1
    [8] => 9
    [44] => 45
    [54] => 55
    [98] => 99
    [296] => 297
    [702] => 703
    [998] => 999
    [2222] => 2223
    [2727] => 2728
    [4878] => 4879
    [4949] => 4950
    [5049] => 5050
    [5291] => 5292
    [7271] => 7272
    [7776] => 7777
    [9998] => 9999
)
54

Picat

Translation of: C++

Using Casting out nines.

go =>
  println(base=10),
  println(kaprekar_number(10,10000)),
  nl,
  println("Testing 1000000:"),

  K10 = kaprekar_number(10,1000000),
  % println(K10),
  nl,
  println(base=16),
  K16 = [I.to_hex_string() : I in kaprekar_number(16,1000000)],
  % println(K16),
  nl,
  
  println(base=17),
  K17 = [to_radix_string(I,17).to_lowercase : I in  kaprekar_number(17,1000000)],
  % println(K17),
  nl,
  
  println(base=36),
  K36 = [to_radix_string(I,36) : I in  kaprekar_number(36,1000000)],
  % println(K36),

  nl.

kaprekar_number(Base,Limit) = Ks =>
  N = ceiling(log(Base,Limit)),
  PaddyCnt = 0,
  Ks = [],
  foreach(Nz in 1..N)
    foreach(K in Base**(Nz-1)..(Base**Nz)-1, K <= Limit)
       if (K*(K-1)) mod (Base-1) == 0 then
          Found = false,
	  foreach(N2 in Nz..Nz*2-1,Found = false)
 	     B = Base**N2,
	     Nr = K*(B-K) div (B-1),
	     Q = K-Nr,
	     if K*K==Q*B+Nr, 0<Nr then
                PaddyCnt := PaddyCnt+1,
                Ks := Ks ++ [K],
		Found := true
	     end
          end
       end
    end
  end,
  println(len=Ks.length).
Output:
base = 10
len = 17
[1,9,45,55,99,297,703,999,2223,2728,4879,4950,5050,5292,7272,7777,9999]

Testing 1000000:
len = 54

base = 16
len = 74

base = 17
len = 24

base = 36
len = 35

PicoLisp

(de kaprekar (N)
   (let L (cons 0 (chop (* N N)))
      (for ((I . R) (cdr L) R (cdr R))
         (NIL (gt0 (format R)))
         (T (= N (+ @ (format (head I L)))) N) ) ) )
Output:
: (filter kaprekar (range 1 10000))
-> (1 9 45 55 99 297 703 999 2223 2728 4879 4950 5050 5292 7272 7777 9999)

: (cnt kaprekar (range 1 1000000))
-> 54

PL/I

kaprekar: procedure options (main);  /* 22 January 2012 */
   declare i fixed decimal (9), j fixed binary;
   declare s character (20) character varying;
   declare m fixed decimal (9);
   declare (z, zeros) character (20) varying;

   zeros = '00000000000000000000';

   put skip list (1);
   do i = 2 to 100000;
      s = i*i;
      s = trim(s);
      z = substr(zeros, 1, length(s));
      do j = 1 to length(s)-1;
         if substr(s, j+1) = substr(z, j+1) then leave;
         m = substr(s, 1, j) + substr(s, j+1);
         if i = m then put skip list (i);
      end;
   end;

end kaprekar;
Output:
   1 
        9 
       45 
       55 
       99 
      297 
      703 
      999 
     2223 
     2728 
     4879 
     4950 
     5050 
     5292 
     7272 
     7777 
     9999

PowerShell

function Test-Kaprekar ([int]$Number)
{
    if ($Number -eq 1)
    {
        return $true
    }

    [int64]$a = $Number * $Number
    [int64]$b = 10

    while ($b -lt $a)
    {
        [int64]$remainder = $a % $b
        [int64]$quotient  = ($a - $remainder) / $b

        if ($remainder -gt 0 -and $remainder + $quotient -eq $Number)
        {
            return $true
        }

        $b *= 10
    }

    return $false
}
"Kaprekar numbers less than 10,000:"
1..10000 | ForEach-Object {if (Test-Kaprekar -Number $_) {"{0,6}" -f $_}} | Format-Wide {$_} -Column 17 -Force

"Kaprekar numbers less than 1,000,000:"
1..1000000 | ForEach-Object {if (Test-Kaprekar -Number $_) {"{0,6}" -f $_}} | Format-Wide {$_} -Column 18 -Force
Output:
Kaprekar numbers less than 10,000:


     1       9      45      55      99     297     703     999    2223    2728    4879    4950    5050    5292    7272    7777   9999


Kaprekar numbers less than 1,000,000:


     1       9      45      55      99     297     703     999    2223   2728   4879   4950   5050   5292   7272   7777   9999  17344
 22222   38962   77778   82656   95121   99999  142857  148149  181819 187110 208495 318682 329967 351352 356643 390313 461539 466830
499500  500500  533170  538461  609687  627615  643357  648648  670033 681318 791505 812890 818181 851851 857143 961038 994708 999999

Prolog

Works with SWI-Prolog, uses a list comprehension : List comprehensions#Prolog

kaprekar_(Z, X) :-
	split_number(Z, 10, X).


split_number(Z, N, X) :-
	N < Z,
	A is Z // N,
	B is Z mod N,
	(   (X is A+B,  B\= 0)-> true; N1 is N*10, split_number(Z, N1, X)).

kaprekar(N, V) :-
	V <- {X & X <- 1 .. N & ((Z is X * X, kaprekar_(Z, X)); X = 1) }.
Output:
 ?- kaprekar(1000, V).
V = [1,9,45,55,99,297,703,999]

 ?- kaprekar(1000000, V), length(V, N), format('Numbers of kaprekar numbers under 1000000 : ~w~n', [N]).
Numbers of kaprekar numbers under 1000000 : 54
V = [1,9,45,55,99,297,703,999,2223,2728,4879,4950,5050,5292,7272,7777,9999,17344,22222,38962,77778,82656,95121,99999,142857,
148149,181819,187110,208495,318682,329967,351352,356643,390313,461539,466830,499500,500500,533170,538461,609687,627615,
643357,648648,670033,681318,791505,812890,818181,851851,857143,961038,994708,999999],
N = 54 .

PureBasic

Translation of: C
Procedure Kaprekar(n.i)
  nn.q  = n*n
  tens.q= 1
  While tens<nn: tens*10: Wend  
  Repeat
    tens/10
    If tens<=n: Break: EndIf
    If nn-n = (nn/tens) * (tens-1)
      ProcedureReturn #True
    EndIf
  ForEver
  If n=1
    ProcedureReturn #True
  EndIf
EndProcedure

If OpenConsole()
  For i=1 To 1000000
    If Kaprekar(i)  
      cnt+1
      PrintN(RSet(Str(cnt),3)+":"+RSet(Str(i),8))
    EndIf
  Next
  ;
  Print("Press ENTER to exit")
  Input()
EndIf
  1:       1
  2:       9
  3:      45
  4:      55
  5:      99
  6:     297
  7:     703
  8:     999
 ...........
 51:  857143
 52:  961038
 53:  994708
 54:  999999
Press ENTER to exit

Python

Splitting strings in a loop

(Swap the commented return statement to return the split information).

>>> def k(n):
	n2 = str(n**2)
	for i in range(len(n2)):
		a, b = int(n2[:i] or 0), int(n2[i:])
		if b and a + b == n:
			return n
			#return (n, (n2[:i], n2[i:]))

		
>>> [x for x in range(1,10000) if k(x)]
[1, 9, 45, 55, 99, 297, 703, 999, 2223, 2728, 4879, 4950, 5050, 5292, 7272, 7777, 9999]
>>> len([x for x in range(1,1000000) if k(x)])
54
>>>

A stronger code that gives a list of Kaprekar numbers within a range in a given base. The range must be given as a decimal number.

def encode(n, base):
    result = ""
    while n:
        n, d = divmod(n, base)
        if d < 10:
            result += str(d)
        else:
            result += chr(d - 10 + ord("a"))
    return result[::-1]
def Kaprekar(n, base):
    if n == '1':
        return True
    sq = encode((int(n, base)**2), base)
    for i in range(1,len(sq)):
        if (int(sq[:i], base) + int(sq[i:], base) == int(n, base)) and (int(sq[:i], base) > 0) and (int(sq[i:], base)>0):
            return True
    return False
def Find(m, n, base):
    return [encode(i, base) for i in range(m,n+1) if Kaprekar(encode(i, base), base)]

m = int(raw_input('Where to start?\n'))
n = int(raw_input('Where to stop?\n'))
base = int(raw_input('Enter base:'))
KNumbers = Find(m, n, base)
for i in KNumbers:
    print i
print 'The number of Kaprekar Numbers found are',
print len(KNumbers)
raw_input()

Using Casting Out Nines Generator

See: http://rosettacode.org/wiki/Casting_out_nines#Python for explanation and code for CastOut

Base = 10
N = 6
Paddy_cnt = 1
for n in range(N):
  for V in CastOut(Base,Start=Base**n,End=Base**(n+1)):
    for B in range(n+1,n*2+2):
      x,y = divmod(V*V,Base**B)
      if V == x+y and 0<y:
        print('{1}: {0}'.format(V, Paddy_cnt))
        Paddy_cnt += 1
        break

Produces:

1: 1
2: 9
3: 45
4: 55
5: 99
6: 297
7: 703
8: 999
9: 2223
10: 2728
11: 4879
12: 4950
13: 5050
14: 5292
15: 7272
16: 7777
17: 9999
18: 17344
19: 22222
20: 38962
21: 77778
22: 82656
23: 95121
24: 99999
25: 142857
26: 148149
27: 181819
28: 187110
29: 208495
30: 318682
31: 329967
32: 351352
33: 356643
34: 390313
35: 461539
36: 466830
37: 499500
38: 500500
39: 533170
40: 538461
41: 609687
42: 627615
43: 643357
44: 648648
45: 670033
46: 681318
47: 791505
48: 812890
49: 818181
50: 851851
51: 857143
52: 961038
53: 994708
54: 999999

Other bases may be used e.g.:

Base = 16
N = 4
Paddy_cnt = 1
for V in CastOut(Base,Start=1,End=Base**N):
  for B in range(1,N*2-1):
    x,y = divmod(V*V,Base**B)
    if V == x+y and 0<y:
      print('{1}: {0:x}'.format(V, Paddy_cnt))
      Paddy_cnt += 1
      break

Produces:

1: 1
2: 6
3: a
4: f
5: 33
6: 55
7: 5b
8: 78
9: 88
10: ab
11: cd
12: ff
13: 15f
14: 334
15: 38e
16: 492
17: 4ed
18: 7e0
19: 820
20: b13
21: b6e
22: c72
23: ccc
24: ea1
25: fa5
26: fff
27: 191a
28: 2a2b
29: 3c3c
30: 4444
31: 5556
32: 6667
33: 7f80
34: 8080
35: 9999
36: aaaa
37: bbbc
38: c3c4
39: d5d5
40: e6e6
41: ffff

Quackery

  [ dup 1 = if done
    dup temp put
    dup *
    false swap 1
    [ base share *
      2dup /mod
      over 0 = iff
        2drop done
      dup 0 = iff
        2drop again
      + temp share = iff
        [ rot not unrot ]
        done
      again ]
    2drop
    temp release ]        is kaprekar ( n --> b )
   
  say "Kaprekar numbers less than one thousand: "
  []
  1000 times
    [ i^ kaprekar if
      [ i^ join ] ]
  echo cr cr
 
  say "Number of Kaprekar numbers less than one million: "
  0
  1000000 times 
    [ i^ kaprekar if 1+ ]
  echo cr cr
 
  say "Base 17 Kaprekar numbers less than one million." cr cr
  17 base put
    []
  1000000 times
    [ i^ kaprekar if
      [ i^ join ] ]
  say "In base 17: "
  dup echo cr
  base release
  say "In decimal: "
  echo
Output:
Kaprekar numbers less than one thousand.[ 1 9 45 55 99 297 703 999 ]

Number of Kaprekar numbers less than one million: 54

Base 17 Kaprekar numbers less than one million.
In base 17: [ 1 G 3D D4 GG 556 BBB GGG 18BD 1F1F 36DB 43CD 61EB 785D 7A96 967B 98B4 AF26 CD44 DA36 F1F2 F854 GGGG 33334 ]
In decimal: [ 1 16 64 225 288 1536 3377 4912 7425 9280 16705 20736 30016 36801 37440 46081 46720 53505 62785 66816 74241 76096 83520 266224 ]

Racket

#lang racket
(define (kaprekar? n)
  (or (= n 1)
      (let ([q (sqr n)])
        (let loop ((p 10))
          (and (<= p q)
               (or (let-values  ([(b a) (quotient/remainder q p)])
                     (and (> a 0) (= n (+ a b))))
                   (loop (* p 10))))))))

(filter kaprekar? (range 1 10000))
'(1 9 45 55 99 297 703 999 2223 2728 4879 4950 5050 5292 7272 7777 9999)

Raku

(formerly Perl 6)

String version (slow)

sub kaprekar( Int $n ) {
    my $sq = $n ** 2;
    for 0 ^..^ $sq.chars -> $i {
        my $x = +$sq.substr(0, $i);
        my $y = +$sq.substr($i) || return;
        return True if $x + $y == $n;
    }
    False;
}

print 1;
print " $_" if .&kaprekar for ^10000;
print "\n";
Output:
1 9 45 55 99 297 703 999 2223 2728 4879 4950 5050 5292 7272 7777 9999

Numeric version (medium)

The addition of race, in two places, allows for concurrent computation, and brings a significant speed-up in running time.
sub kaprekar( Int $n, Int :$base = 10 ) {
    my $hi = $n ** 2;
    my $lo = 0;
    loop (my $s = 1; $hi; $s *= $base) {
        $lo += ($hi % $base) * $s;
        $hi div= $base;
        return $hi,$lo if $lo + $hi == $n and $lo;
    }
    ();
}

print " $_" if .&kaprekar for ^10_000;

my atomicint $n;
(^1_000_000).race.map: { $n++ if kaprekar $_ }
say "\n\nBase 10 Kaprekar numbers < :10<1_000_000> = $n";

say "\nBase 17 Kaprekar numbers < :17<1_000_000>";

my &k17 = &kaprekar.assuming(:base(17));

my @results;
(^:17<1_000_000>).race.map: -> $n {
    my ($h,$l) = k17 $n;
    next unless $l;
    my $n17 = $n.base(17);
    my $s17 = ($n * $n).base(17);
    my $h17 = $h.base(17);
    @results.push: "$n $n17 $s17 ($h17 + $s17.substr(* - max(1,($s17.chars - $h17.chars))))";
}

.say for @results.sort: *.chars;
Output:
1 9 45 55 99 297 703 999 2223 2728 4879 4950 5050 5292 7272 7777 9999

Base 10 Kaprekar numbers < :10<1_000_000> = 54

Base 17 Kaprekar numbers < :17<1_000_000>
1 1 1 (0 + 1)
16 G F1 (F + 1)
64 3D E2G (E + 2G)
225 D4 A52G (A5 + 2G)
288 GG GF01 (GF + 01)
1536 556 1B43B2 (1B4 + 3B2)
3377 BBB 8093B2 (809 + 3B2)
4912 GGG GGF001 (GGF + 001)
7425 18BD 24E166G (24E + 166G)
9280 1F1F 39B1B94 (39B + 1B94)
16705 36DB B992C42 (B99 + 2C42)
20736 43CD 10DE32FG (10DE + 32FG)
30016 61EB 23593F92 (2359 + 3F92)
36801 785D 351E433G (351E + 433G)
37440 7A96 37144382 (3714 + 4382)
46081 967B 52G94382 (52G9 + 4382)
46720 98B4 5575433G (5575 + 433G)
53505 AF26 6GA43F92 (6GA4 + 3F92)
62785 CD44 9A5532FG (9A55 + 32FG)
66816 DA36 AEG42C42 (AEG4 + 2C42)
74241 F1F2 D75F1B94 (D75F + 1B94)
76096 F854 E1F5166G (E1F5 + 166G)
83520 GGGG GGGF0001 (GGGF + 0001)
266224 33334 A2C52A07G (A2C5 + 2A07G)
1153633 DDDDD B3D5E2A07G (B3D5E + 2A07G)
1334529 FGACC F0540F1A78 (F054 + 0F1A78)
1419856 GGGGG GGGGF00001 (GGGGF + 00001)
1787968 146FCA 19G4C12DG7F (19G4C + 12DG7F)
3122497 236985 4E3BE1F95D8 (4E3BE + 1F95D8)
3773952 2B32B3 711CB2420F9 (711CB + 2420F9)
4243968 2GDE03 8FEGB27EG09 (8FEGB + 27EG09)
5108481 3A2D6F CG10B2E3C64 (CG10B + 2E3C64)
5561920 3FA16D F5EAE3043CG (F5EAE + 3043CG)
6031936 443CCD 110DDE332FFG (110DDE + 332FFG)
6896449 4E9C28 16A10C37GB1D (16A10C + 37GB1D)
7435233 54067B 1A72G93AA382 (1A72G9 + 3AA382)
8017920 5AGGB6 1EF1D43D1EF2 (1EF1D4 + 3D1EF2)
9223201 687534 2835C5403G7G (2835C5 + 403G7G)
9805888 6F6F6G 2DBE3F41C131 (2DBE3F + 41C131)
11140416 7E692A 3A997C43DGBF (3A997C + 43DGBF)
11209185 7F391E 3B58D543F059 (3B58D5 + 43F059)
12928384 91D7F3 4EF79B43F059 (4EF79B + 43F059)
12997153 92A7E7 4FD82943DGBF (4FD829 + 43DGBF)
14331681 A1A1A1 5GF07041C131 (5GF070 + 41C131)
14914368 A89BDD 685C5E403G7G (685C5E + 403G7G)
16119649 B6005B 79F2793D1EF2 (79F279 + 3D1EF2)
16702336 BCGA96 8267143AA382 (826714 + 3AA382)
17241120 C274E9 8B7ACD37GB1D (8B7ACD + 37GB1D)
18105633 CCD444 99A555332FFG (99A555 + 332FFG)
18575649 D16FA4 A12BE53043CG (A12BE5 + 3043CG)
19029088 D6E3A2 A9A83F2E3C64 (A9A83F + 2E3C64)
19893601 E032GE B953G527EG09 (B953G5 + 27EG09)
20363617 E5DE5E C1BD752420F9 (C1BD75 + 2420F9)
21015072 EDA78C CF11C41F95D8 (CF11C4 + 1F95D8)
22349601 FCA147 E9D1D912DG7F (E9D1D9 + 12DG7F)
22803040 G10645 F2FCDE0F1A78 (F2FCDE + 0F1A78)
24137568 GGGGGG GGGGGF000001 (GGGGGF + 000001)

Note that this algorithm allows the null string on the left, taken as zero, which automatically includes 1 as the first element of the sequence.

Casting out nines (fast)

sub kaprekar-generator( :$base = 10 ) {
    my $base-m1 = $base - 1;
    gather loop (my $place = 1; ; ++$place) {
        my $nend = $base ** $place;
        loop (my $n = $base ** ($place - 1); $n < $nend; ++$n) {
            if $n * ($n - 1) %% $base-m1 {
                my $pend = $place * 2;
                loop (my $p = $place; $p < $pend; ++$p) {
                    my $B = $base ** $p;
                    my $lo = $n * ($B - $n) div ($B - 1);
                    my $hi = floor $n - $lo;
                    if $n * $n == $hi * $B + $lo and $lo {
                        take [$n, $hi, $lo];
                        last;
                    }
                }
            }
        }
    }
}

print " $_[0]" for kaprekar-generator() ...^ *.[0] >= 10_000;
say "\n";

say "Base 10 Kaprekar numbers < :10<1_000_000> = ", +(kaprekar-generator() ...^ *.[0] >= 1000000);
say '';

say "Base 17 Kaprekar numbers < :17<1_000_000>";

my &k17-gen = &kaprekar-generator.assuming(:base(17));

for k17-gen() ...^ *.[0] >= :17<1000000> -> @r {
    my ($n,$h,$l) = @r;
    my $n17 = $n.base(17);
    my $s = $n * $n;
    my $s17 = $s.base(17);
    my $h17 = $h.base(17);
    my $l17 = $l.base(17);
    $l17 = '0' x ($s17.chars - $h17.chars - $l17.chars) ~ $l17;
    say "$n $n17 $s17 ($h17 + $l17)";
}

(Same output.)

REXX

           ╔═══════════════════════════════════════════════════════════════════╗
           ║ Kaprekar numbers were thought of by the mathematician from India, ║
           ║ Shri Dattathreya Ramachardra Kaprekar  (1905 ───► 1986).          ║
           ╚═══════════════════════════════════════════════════════════════════╝
/*REXX pgm generates & counts (& maybe shows) some Kaprekar #s using the cast─out─9 test*/
parse arg A B .                                  /*obtain optional arguments from the CL*/
if A=='' | A=","  then A=    10000               /*Not specified?  Then use the default.*/
if B=='' | B=","  then B= -1000000               /* "      "         "   "   "     "    */
call Kaprekar          A                         /*gen Kaprekar numbers and display 'em.*/
call Kaprekar          B                         /* "     "        "   don't    "     " */
exit 0                                           /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
Kaprekar: procedure; parse arg N;  aN= abs(N)    /*obtain the limit;   use  │N│  value. */
          numeric digits max(9, 2 * length(aN) ) /*use enough decimal digits for square.*/
          d= digits();         tell= N>0         /*set D to number of digits;  set TELL.*/
          #= 0;       if aN>0  then do;    #= 1;    if tell  then say right(1, d);    end
                                                 /* [↑]  handle case of  N  being unity.*/
          if aN>1  then do j=9  for aN-9;        /*calculate the  square  of  J   (S).  */
                        jc= j//9                 /*JC:   J modulo 9   (cast out nines). */
                        if jc >2  then iterate   /*Is  J mod 9 > two?  Then skip this J.*/
                        s= j*j                   /*calculate the  square  of  J   (S).  */
                        if jc==s//9  then do k=1  for length(s)%2   /*≡ casted out 9's? */
                                          parse var    s      L   +(k)   R
                                          if j\==L+R  then iterate
                                          #= # + 1;   if tell  then say right(j, d); leave
                                          end   /*k*/
                        end   /*j*/
          say
          say center(" There're "     #     ' Kaprekar numbers below '     aN" ", 79, "═")
          return
output   when using the default inputs of:       10000   -1000000
         1
         9
        45
        55
        99
       297
       703
       999
      2223
      2728
      4879
      4950
      5050
      5292
      7272
      7777
      9999

═════════════════ There're  17  Kaprekar numbers below  10000 ═════════════════

════════════════ There're  54  Kaprekar numbers below  1000000 ════════════════

Ring

nr = 0
for i = 1 to 200
    if kaprekar(i)
       nr += 1
       if i < 201 see "" + nr + " : " + i + nl ok ok
next
see "total kaprekar numbers under 200 = " + nr + nl
 
func kaprekar n
     s = pow(n,2)
     x = floor(log(s)) + 1
     t = pow(10,x) 
     while true
           t /= 10
           if t<=n exit ok
           if s-n = floor(s/t)*(t-1) n = true ok
     end
     return (n = 1)

Output:

1 : 1
2 : 9
3 : 45
4 : 55
5 : 99
total kaprekar numbers under 200 = 5

RPL

Translation of: Python
Works with: Halcyon Calc version 4.2.7
RPL code Comment
 ≪ DUP SQ →STR DUP SIZE → n n2 n2s
   ≪ 1 CF 1 n2s 1 - FOR j
        IF n2 j 1 + n2s SUB STR→ THEN
           LAST n2 1 j SUB STR→ 
           IF DUP2 + n == 
           THEN 1 SF n2s 'j' STO ELSE DROP2 END 
        END
      NEXT 
      IF 1 FS? 
      THEN n →STR "=" + SWAP →STR + "+" + SWAP →STR +
      ELSE "" END
≫ ≫ 'KPREK' STO

≪ { 1 } 9 10000 FOR n 0 1 FOR k
     n k + KPREK IF DUP "" ≠ THEN + ELSE DROP END
   NEXT 9 STEP
≫ 'TASK' STO  
KPREK ( n -- string )
Examine all the possible a|b cuts of n²
if b is not zero
    restore b in stack and get a
    if a + b == n 
       then exit loop


if a and b found
   then edit result
   else return an empty string


TASK: Loop ad examine 
  only numbers mod 9 = 0 or 1 (see Maple section)


Output:
1: { 1 "9=8+1" "45=20+25" "55=30+25" "99=98+1" "297=88+209" "703=494+209" "999=998+1" "2223=494+1729" "2728=744+1984" "4879=238+4641" "4950=2450+2500" "5050=2550+2500" "5292=28+5264" "7272=5288+1984" "7777=6048+1729" "9999=9998+1" }

Ruby

with extra extra credit

def kaprekar(n, base = 10)
  return [1, 1, 1, ""] if n == 1 
  return if n*(n-1) % (base-1) != 0     # casting out nine
  sqr = (n ** 2).to_s(base)
  (1...sqr.length).each do |i|
    a = sqr[0 ... i]
    b = sqr[i .. -1]
    break if b.delete("0").empty?
    sum = a.to_i(base) + b.to_i(base)
    return n.to_s(base), sqr, a, b if sum == n
  end
  nil
end

count = 0
1.upto(10_000 - 1) do |i| 
  if result = kaprekar(i)
    puts "%4d  %8d  %s + %s" % result
    count += 1
  end
end

10_000.upto(1_000_000 - 1) {|i| count += 1 if kaprekar(i)}
puts "#{count} kaprekar numbers under 1,000,000"

puts "\nbase17 kaprekar numbers under (base10)1,000,000"
base = 17
1.upto(1_000_000) do |decimal|
  if result = kaprekar(decimal, base)
    puts "%7s  %5s  %9s  %s + %s" % [decimal, *result]
  end
end
Output:
   1         1  1 + 
   9        81  8 + 1
  45      2025  20 + 25
  55      3025  30 + 25
  99      9801  98 + 01
 297     88209  88 + 209
 703    494209  494 + 209
 999    998001  998 + 001
2223   4941729  494 + 1729
2728   7441984  744 + 1984
4879  23804641  238 + 04641
4950  24502500  2450 + 2500
5050  25502500  2550 + 2500
5292  28005264  28 + 005264
7272  52881984  5288 + 1984
7777  60481729  6048 + 1729
9999  99980001  9998 + 0001
54 kaprekar numbers under 1,000,000

base17 kaprekar numbers under (base10)1,000,000
      1      1          1  1 + 
     16      g         f1  f + 1
     64     3d        e2g  e + 2g
    225     d4       a52g  a5 + 2g
    288     gg       gf01  gf + 01
   1536    556     1b43b2  1b4 + 3b2
   3377    bbb     8093b2  809 + 3b2
   4912    ggg     ggf001  ggf + 001
   7425   18bd    24e166g  24e + 166g
   9280   1f1f    39b1b94  39b + 1b94
  16705   36db    b992c42  b99 + 2c42
  20736   43cd   10de32fg  10de + 32fg
  30016   61eb   23593f92  2359 + 3f92
  36801   785d   351e433g  351e + 433g
  37440   7a96   37144382  3714 + 4382
  46081   967b   52g94382  52g9 + 4382
  46720   98b4   5575433g  5575 + 433g
  53505   af26   6ga43f92  6ga4 + 3f92
  62785   cd44   9a5532fg  9a55 + 32fg
  66816   da36   aeg42c42  aeg4 + 2c42
  74241   f1f2   d75f1b94  d75f + 1b94
  76096   f854   e1f5166g  e1f5 + 166g
  83520   gggg   gggf0001  gggf + 0001
 266224  33334  a2c52a07g  a2c5 + 2a07g

Run BASIC

for i   = 1 to 5000
  x$    = str$(i * i)
  if i  = 1 then x$ = "10"
  for j = 1 to len(x$) - 1
   if (val(left$(x$,j)) + val(mid$(x$,j+1)) = i and val(mid$(x$,j+1)) <> 0) or i = 1  then print "Kaprekar :";left$(x$,j);" + ";mid$(x$,j+1);" = ";i
  next j
next i
Kaprekar :1 + 0 = 1
Kaprekar :8 + 1 = 9
Kaprekar :20 + 25 = 45
Kaprekar :30 + 25 = 55
Kaprekar :98 + 01 = 99
Kaprekar :88 + 209 = 297
Kaprekar :494 + 209 = 703
Kaprekar :998 + 001 = 999
Kaprekar :494 + 1729 = 2223
Kaprekar :744 + 1984 = 2728
Kaprekar :238 + 04641 = 4879

Scala

Works with: Scala version 2.9.1
object Kaprekar extends App {

  def isKaprekar(n: Int, base: Int = 10):Option[Triple[String,String,String]] = {
    val check: Long => Option[Triple[String,String,String]] = n => {
      val split: Pair[String, Int] => Pair[String, String] = p => (p._1.slice(0,p._2),p._1.slice(p._2,p._1.size).padTo[Char,String](1,'0'))
      val pwr = n*n
      val sN = java.lang.Long.toString(n, base)
      val sPwr = java.lang.Long.toString(pwr, base)
      for (i <- 1 to sPwr.size) {
        val (a, b) = split(sPwr,i)
        val la = java.lang.Long.parseLong(a, base)
        val lb = java.lang.Long.parseLong(b, base)
        if (lb==0) return None
        if (la+lb==n) return Some(Triple(sPwr,a,b))
      }
      None    
    }
    n match {
      case 1 => Some(Triple("1","0","1"))
      case n if (n>1) => check(n)
      case _ => None
    }
  }

  def kaprekars(n: Int,base: Int=10) = (1 to n).map(isKaprekar(_,base)).zip(1 to n).filter(_._1!=None).map(p=>Triple(base,p._2,p._1 match {case Some(t) => t; case _ => Nil}))

  val k1 = kaprekars(10000)
  k1 foreach {p=>println(p._2)}
  println(k1.size + " Kaprekar numbers < 10000 (b:10) for base 10"+"\n"*2)

  val k2 = kaprekars(1000000)
  k2 foreach {p => println(p._2+"\t"+java.lang.Long.toString(p._2,p._1)+"\t"+p._3.productElement(0)+"\t"+p._3.productElement(1)+" + "+p._3.productElement(2))}
  println(k2.size + " Kaprekar numbers < 1000000 (b:10) for base 10"+"\n"*2)

  val k3 = kaprekars(1000000,17)
  k3 foreach {p => println(p._2+"\t"+java.lang.Long.toString(p._2,p._1)+"\t"+p._3.productElement(0)+"\t"+p._3.productElement(1)+" + "+p._3.productElement(2))}
  println(k3.size + " Kaprekar numbers < 1000000 (b:10) for base 17"+"\n"*2)

}
Output:
1
9
45
55
99
297
703
999
2223
2728
4879
4950
5050
5292
7272
7777
9999
17 Kaprekar numbers < 10000 (b:10) for base 10


1       1       1       0 + 1
9       9       81      8 + 1
45      45      2025    20 + 25
55      55      3025    30 + 25
99      99      9801    98 + 01
297     297     88209   88 + 209
703     703     494209  494 + 209
999     999     998001  998 + 001
2223    2223    4941729 494 + 1729
2728    2728    7441984 744 + 1984
4879    4879    23804641        238 + 04641
4950    4950    24502500        2450 + 2500
5050    5050    25502500        2550 + 2500
5292    5292    28005264        28 + 005264
7272    7272    52881984        5288 + 1984
7777    7777    60481729        6048 + 1729
9999    9999    99980001        9998 + 0001
17344   17344   300814336       3008 + 14336
22222   22222   493817284       4938 + 17284
38962   38962   1518037444      1518 + 037444
77778   77778   6049417284      60494 + 17284
82656   82656   6832014336      68320 + 14336
95121   95121   9048004641      90480 + 04641
99999   99999   9999800001      99998 + 00001
142857  142857  20408122449     20408 + 122449
148149  148149  21948126201     21948 + 126201
181819  181819  33058148761     33058 + 148761
187110  187110  35010152100     35010 + 152100
208495  208495  43470165025     43470 + 165025
318682  318682  101558217124    101558 + 217124
329967  329967  108878221089    108878 + 221089
351352  351352  123448227904    123448 + 227904
356643  356643  127194229449    127194 + 229449
390313  390313  152344237969    152344 + 237969
461539  461539  213018248521    213018 + 248521
466830  466830  217930248900    217930 + 248900
499500  499500  249500250000    249500 + 250000
500500  500500  250500250000    250500 + 250000
533170  533170  284270248900    284270 + 248900
538461  538461  289940248521    289940 + 248521
609687  609687  371718237969    371718 + 237969
627615  627615  393900588225    39390 + 0588225
643357  643357  413908229449    413908 + 229449
648648  648648  420744227904    420744 + 227904
670033  670033  448944221089    448944 + 221089
681318  681318  464194217124    464194 + 217124
791505  791505  626480165025    626480 + 165025
812890  812890  660790152100    660790 + 152100
818181  818181  669420148761    669420 + 148761
851851  851851  725650126201    725650 + 126201
857143  857143  734694122449    734694 + 122449
961038  961038  923594037444    923594 + 037444
994708  994708  989444005264    989444 + 005264
999999  999999  999998000001    999998 + 000001
54 Kaprekar numbers < 1000000 (b:10) for base 10


1       1       1       0 + 1
16      g       f1      f + 1
64      3d      e2g     e + 2g
225     d4      a52g    a5 + 2g
288     gg      gf01    gf + 01
1536    556     1b43b2  1b4 + 3b2
3377    bbb     8093b2  809 + 3b2
4912    ggg     ggf001  ggf + 001
7425    18bd    24e166g 24e + 166g
9280    1f1f    39b1b94 39b + 1b94
16705   36db    b992c42 b99 + 2c42
20736   43cd    10de32fg        10de + 32fg
30016   61eb    23593f92        2359 + 3f92
36801   785d    351e433g        351e + 433g
37440   7a96    37144382        3714 + 4382
46081   967b    52g94382        52g9 + 4382
46720   98b4    5575433g        5575 + 433g
53505   af26    6ga43f92        6ga4 + 3f92
62785   cd44    9a5532fg        9a55 + 32fg
66816   da36    aeg42c42        aeg4 + 2c42
74241   f1f2    d75f1b94        d75f + 1b94
76096   f854    e1f5166g        e1f5 + 166g
83520   gggg    gggf0001        gggf + 0001
266224  33334   a2c52a07g       a2c5 + 2a07g
24 Kaprekar numbers < 1000000 (b:10) for base 17

Scheme

; auxiliary functions : range, filter
(define (range a b)
(let loop ((v '()) (i b))
(if (< i a)
    v
    (loop (cons i v)
          (- i 1)))))

(define (filter p u)
(if (equal? u '())
    '()
    (let ((x (car u)) (v (filter p (cdr u))))
         (if (p x)
             (cons x v)
             v))))

(define (kaprekar? n)
(or (= n 1)
    (let ((q (* n n)))
    (let loop ((p 10))
         (cond ((> p q) #f)
               ((let ((a (remainder q p)) (b (quotient q p)))
                     (and (> a 0) (= n (+ a b)))) #t)
               (else (loop (* p 10))))))))

(filter kaprekar? (range 1 10000))
; (1 9 45 55 99 297 703 999 2223 2728 4879 4950 5050 5292 7272 7777 9999)

Seed7

$ include "seed7_05.s7i";
  include "bigint.s7i";

const func bigInteger: kaprekar (in bigInteger: n, in bigInteger: base) is func
  result
    var bigInteger: kaprekar is 0_;
  local
    var bigInteger: nn is 0_;
    var bigInteger: r is 0_;
    var bigInteger: powerOfBase is 1_;
  begin
    nn := n ** 2;
    while powerOfBase < n do
      powerOfBase *:= base;
    end while;
    if n = powerOfBase then
      kaprekar := bigInteger conv ord(n = 1_);
    else
      r := nn rem powerOfBase;
      while r < n do
        if nn div powerOfBase + r = n then
          kaprekar := powerOfBase;
          r := n;
        else
	  powerOfBase *:= base;
          r := nn rem powerOfBase;
        end if;
      end while;
    end if;
  end func;

const proc: main is func
  local
    var bigInteger: aNumber is 0_;
    var integer: count is 0;
    var bigInteger: powerOfBase is 1_;
    const integer: base is 17;
  begin
    writeln("base 10:");
    for aNumber range 1_ to 1000000_ do
      if kaprekar(aNumber, 10_) <> 0_ then
        incr(count);
        writeln(count lpad 3 <& ": " <& aNumber);
      end if;
    end for;
    writeln;
    writeln("base " <& base <& ":");
    writeln("  1: 1");
    count := 1;
    for aNumber range 2_ to 1000000_ do
      powerOfBase := kaprekar(aNumber, bigInteger conv base);
      if powerOfBase <> 0_ then
        incr(count);
        write(count lpad 3 <& ": " <& aNumber);
        write(" \t" <& aNumber radix base);
        write("\t"  <& aNumber ** 2 radix base);
        write("\t"  <& aNumber ** 2 mdiv powerOfBase radix base);
        write(" + " <& aNumber ** 2 mod powerOfBase radix base);
        writeln;
      end if;
    end for;
  end func;
Output:
base 10:
  1: 1
  2: 9
  3: 45
  4: 55
  5: 99
  6: 297
  7: 703
  8: 999
  9: 2223
 10: 2728
 11: 4879
 12: 4950
 13: 5050
 14: 5292
 15: 7272
 16: 7777
 17: 9999
 18: 17344
 19: 22222
 20: 38962
 21: 77778
 22: 82656
 23: 95121
 24: 99999
 25: 142857
 26: 148149
 27: 181819
 28: 187110
 29: 208495
 30: 318682
 31: 329967
 32: 351352
 33: 356643
 34: 390313
 35: 461539
 36: 466830
 37: 499500
 38: 500500
 39: 533170
 40: 538461
 41: 609687
 42: 627615
 43: 643357
 44: 648648
 45: 670033
 46: 681318
 47: 791505
 48: 812890
 49: 818181
 50: 851851
 51: 857143
 52: 961038
 53: 994708
 54: 999999

base 17:
  1: 1
  2: 16 	G	F1	F + 1
  3: 64 	3D	E2G	E + 2G
  4: 225 	D4	A52G	A5 + 2G
  5: 288 	GG	GF01	GF + 1
  6: 1536 	556	1B43B2	1B4 + 3B2
  7: 3377 	BBB	8093B2	809 + 3B2
  8: 4912 	GGG	GGF001	GGF + 1
  9: 7425 	18BD	24E166G	24E + 166G
 10: 9280 	1F1F	39B1B94	39B + 1B94
 11: 16705 	36DB	B992C42	B99 + 2C42
 12: 20736 	43CD	10DE32FG	10DE + 32FG
 13: 30016 	61EB	23593F92	2359 + 3F92
 14: 36801 	785D	351E433G	351E + 433G
 15: 37440 	7A96	37144382	3714 + 4382
 16: 46081 	967B	52G94382	52G9 + 4382
 17: 46720 	98B4	5575433G	5575 + 433G
 18: 53505 	AF26	6GA43F92	6GA4 + 3F92
 19: 62785 	CD44	9A5532FG	9A55 + 32FG
 20: 66816 	DA36	AEG42C42	AEG4 + 2C42
 21: 74241 	F1F2	D75F1B94	D75F + 1B94
 22: 76096 	F854	E1F5166G	E1F5 + 166G
 23: 83520 	GGGG	GGGF0001	GGGF + 1
 24: 266224 	33334	A2C52A07G	A2C5 + 2A07G

Sidef

Translation of: Perl
var kapr = Set()

for n in (1..15) {
    var k = (10**n - 1)
    k.udivisors.each {|d|
        var dp = k/d
        kapr << (dp == 1 ? d : d*invmod(d, dp))
    }
}

say kapr.grep { .<= 1e4 }.sort

for n in (6 .. 14) {
    var k = (10**n - 1)
    printf("Kaprekar numbers <= 10^%2d:  %5d\n", n, kapr.count_by { .<= k })
}
Output:
[1, 9, 45, 55, 99, 297, 703, 999, 2223, 2728, 4879, 4950, 5050, 5292, 7272, 7777, 9999]
Kaprekar numbers <= 10^ 6:     54
Kaprekar numbers <= 10^ 7:     62
Kaprekar numbers <= 10^ 8:     91
Kaprekar numbers <= 10^ 9:    102
Kaprekar numbers <= 10^10:    132
Kaprekar numbers <= 10^11:    149
Kaprekar numbers <= 10^12:    264
Kaprekar numbers <= 10^13:    281
Kaprekar numbers <= 10^14:    316

SPL

kap,n = getkap(1000000)
> i, 1..n
  << kap[i]!<10000
  #.output(kap[i])
<
#.output(n," Kaprekar numbers < 1000000")

getkap(x)=
  > k, 1..x
    n = #.lower(#.log10(k^2))+1
    > i, 1..n
      r = k^2%10^i
      << r>k
      >> r=0
      l = #.lower(k^2/10^i)
      ? r+l=k, kap[#.size(kap,1)+1] = k
    <
  <
  <= kap,#.size(kap,1)
.
Output:
1
9
45
55
99
297
703
999
2223
2728
4879
4950
5050
5292
7272
7777
9999
54 Kaprekar numbers < 1000000

Tcl

package require Tcl 8.5;   # Arbitrary precision arithmetic, for stretch goal only
proc kaprekar n {
    if {$n == 1} {return 1}
    set s [expr {$n * $n}]
    for {set i 1} {$i < [string length $s]} {incr i} {
	scan $s "%${i}d%d" a b
	if {$b && $n == $a + $b} {
	    return 1
	    #return [list 1 $a $b]
	}
    }
    return 0
}

# Base goal
for {set i 1} {$i < 10000} {incr i} {
    if {[kaprekar $i]} {lappend klist $i}
}
puts [join $klist ", "]

# Stretch goal
for {set i 1} {$i < 1000000} {incr i} {
    incr kcount [kaprekar $i]
}
puts "$kcount Kaprekar numbers less than 1000000"
Output:
1, 9, 45, 55, 99, 297, 703, 999, 2223, 2728, 4879, 4950, 5050, 5292, 7272, 7777, 9999
54 Kaprekar numbers less than 1000000

Ursala

First we define a function kd parameterized by a pair of functions p and r for printing and reading natural numbers, which takes a natural number to its Kaprekar decomposition if any.

#import std
#import nat

kd("p","r") = ~&ihB+ (~&rr&& ^|E/~& sum)~|^/~& "r"~~*hNCtXS+ cuts\1+ "p"+ product@iiX

#cast %nLnX

t = ^|(~&,length) (iota; :/1+ ~&rFlS+ * ^/~& kd\%np ~&h+ %nP)~~/10000 1000000

The kd function parameterized by the built in decimal printing and reading functions is applied to the sequences from zero to 10000 and zero to 1000000, with the results filtered according to whether the decomposition exists. The inputs in the former case and the length in the latter are shown.

(
   <
      1,
      9,
      45,
      55,
      99,
      297,
      703,
      999,
      2223,
      2728,
      4879,
      4950,
      5050,
      5292,
      7272,
      7777,
      9999>,
   54)

For the rest of the task, functions p and r are defined for numbers in base 17.

p = ||'0'! ~&a^& ^|J(~&,division\17); ^lrNCT/~&falPR @ar -$/iota17 digits--'abcdefg'

r = sum^|(~&,product/17)=>0+ *x -$/digits--'abcdefg' iota17

#show+

t = mat` *K7 pad` *K7 ^C(~&h+ %nP@l,p*+ <.~&l,product@llX,~&rl,~&rr>)*rF ^(~&,kd/p r@h)* iota 1000000

The kd function is parameterized by them and a table of results for numbers between 1 and 1000000 is displayed.

16     g     f1        f    1    
64     3d    e2g       e    2g   
225    d4    a52g      a5   2g   
288    gg    gf01      gf   1    
1536   556   1b43b2    1b4  3b2  
3377   bbb   8093b2    809  3b2  
4912   ggg   ggf001    ggf  1    
7425   18bd  24e166g   24e  166g 
9280   1f1f  39b1b94   39b  1b94 
16705  36db  b992c42   b99  2c42 
20736  43cd  10de32fg  10de 32fg 
30016  61eb  23593f92  2359 3f92 
36801  785d  351e433g  351e 433g 
37440  7a96  37144382  3714 4382 
46081  967b  52g94382  52g9 4382 
46720  98b4  5575433g  5575 433g 
53505  af26  6ga43f92  6ga4 3f92 
62785  cd44  9a5532fg  9a55 32fg 
66816  da36  aeg42c42  aeg4 2c42 
74241  f1f2  d75f1b94  d75f 1b94 
76096  f854  e1f5166g  e1f5 166g 
83520  gggg  gggf0001  gggf 1    
266224 33334 a2c52a07g a2c5 2a07g

Visual Basic .NET

Translation of: FreeBASIC
Module Module1

    ReadOnly max As ULong = 1000000

    Function Kaprekar(n As ULong) As Boolean
        If n = 1 Then Return True

        Dim sq = n * n
        Dim sq_str = Str(sq)
        Dim l = Len(sq_str)

        For x = l - 1 To 1 Step -1
            If sq_str(x) = "0" Then
                l = l - 1
            Else
                Exit For
            End If
        Next

        For x = 1 To l - 1
            Dim p2 = Val(Mid(sq_str, x + 1))
            If p2 > n Then
                Continue For
            End If
            Dim p1 = Val(Left(sq_str, x))
            If p1 > n Then Return False
            If (p1 + p2) = n Then Return True
        Next

        Return False
    End Function

    Sub Main()
        Dim count = 0

        Console.WriteLine("Kaprekar numbers below 10000")

        For n = 1 To max - 1
            If Kaprekar(n) Then
                count = count + 1
                If n < 10000 Then
                    Console.WriteLine("{0,2} {1,4}", count, n)
                End If
            End If
        Next

        Console.WriteLine()
        Console.WriteLine("{0} numbers below {1} are kaprekar numbers", count, max)
    End Sub

End Module
Output:
Kaprekar numbers below 10000
 1    1
 2    9
 3   45
 4   55
 5   99
 6  297
 7  703
 8  999
 9 2223
10 2728
11 4879
12 4950
13 5050
14 5292
15 7272
16 7777
17 9999

54 numbers below 1000000 are kaprekar numbers

V (Vlang)

Translation of: go
import strconv

fn kaprekar(n u64, base u64) (bool, int) {
    mut order := 0
    if n == 1 {
        return true, -1
    }
 
    nn, mut power := n*n, u64(1)
    for power <= nn {
        power *= base
        order++
    }
 
    power /= base
    order--
    for ; power > 1; power /= base {
        q, r := nn/power, nn%power
        if q >= n {
            return false, -1
        }
 
        if q+r == n {
            return true, order
        }
 
        order--
    }
 
    return false, -1
}
 
fn main() {
    mut max := u64(10000)
    println("Kaprekar numbers < $max:")
    for m := u64(0); m < max; m++ {
        isk, _ := kaprekar(m, 10)
        if isk {
            println("  $m")
        }
    }
 
    // extra credit
    max = u64(1e6)
    mut count := 0
    for m := u64(0); m < max; m++ {
        isk, _ := kaprekar(m, 10)
        if isk {
            count++
        }
    }
    println("\nThere are $count Kaprekar numbers < ${max}.")
 
    // extra extra credit
    base := 17
    max_b := "1000000"
    println("\nKaprekar numbers between 1 and ${max_b}(base ${base}):")
    max, _ = strconv.common_parse_uint2(max_b, base, 64)
    println("\n Base 10  Base ${base}        Square       Split")
    for m := u64(2); m < max; m++ {
        isk, pos := kaprekar(m, u64(base))
        if !isk {
            continue
        }
        sq := strconv.format_uint(m*m, base)
        str := strconv.format_uint(m, base)
        split := sq.len-pos
        println("${m:8}  ${str:7}  ${sq:12}  ${sq[..split]:6} + ${sq[split..]}") // optional extra extra credit
    }
}
Output:
Same as Go output

Wortel

@let {
  isKap &n [
    @var s +'' *n n
    @for i til +1/#s 2 [
      @vars {
        fn @+!!s.slice 0 i 
        sn @+!s.slice i
      }
      @if =0 sn @break
      @if =n +fn sn @return [fn sn]
    ]
    false
  ]

  ~[
    !console.log "Kaprekar numbers below 10000: {!-isKap @to 1TK}"
    !console.log "Number of Kaprekar numbers below 1000000: {#!-isKap @to 1M}"
  ]
}
Output:
Kaprekar numbers below 10000: 1,9,45,55,99,297,703,999,2223,2728,4879,4950,5050,5292,7272,7777,9999
Number of Kaprekar numbers below 1000000: 54

Wren

Translation of: Go
Library: Wren-fmt
import "./fmt" for Fmt, Conv

var kaprekar = Fn.new { |n, base|
    var order = 0
    if (n == 1) return [true, -1]
    var nn = n * n
    var power = 1
    while (power <= nn) {
        power = power * base
        order = order + 1
    }
    power = (power/base).floor
    order = order - 1
    while (power > 1) {
        var q = (nn/power).floor
        var r = nn % power
        if (q >= n) return [false, -1]
        if (q + r == n) return [true, order]
        order = order - 1
        power = (power/base).floor
    }
    return [false, -1]
}

var max = 1e4
System.print("Kaprekar numbers < %(max):")
for (m in 0...max) {
    var res = kaprekar.call(m, 10)
    if (res[0]) Fmt.print("$6d", m)
}

max = 1e6
var count = 0
for (m in 0...max) {
    var res = kaprekar.call(m, 10)
    if (res[0]) count = count + 1
}
System.print("\nThere are %(count) Kaprekar numbers < %(max).")

var base = 17
var maxB = 1e6.toString
System.print("\nKaprekar numbers between 1 and %(maxB)(base %(base)):")
max = Conv.atoi(maxB, base)
Fmt.print("\n Base 10  Base $d        Square       Split", base)
for (m in 2...max) {
    var res = kaprekar.call(m, base)
    if (res[0]) {
        var sq = Conv.itoa(m*m, base)
        var str = Conv.itoa(m, base)
        var split = sq.count - res[1]
        Fmt.print("$8d  $7s  $12s  $6s + $s", m, str, sq, sq[0...split], sq[split..-1])
    }
}
Output:
Kaprekar numbers < 10000:
     1
     9
    45
    55
    99
   297
   703
   999
  2223
  2728
  4879
  4950
  5050
  5292
  7272
  7777
  9999

There are 54 Kaprekar numbers < 1000000.

Kaprekar numbers between 1 and 1000000(base 17):

 Base 10  Base 17        Square       Split
      16        g            f1       f + 1
      64       3d           e2g       e + 2g
     225       d4          a52g      a5 + 2g
     288       gg          gf01      gf + 01
    1536      556        1b43b2     1b4 + 3b2
    3377      bbb        8093b2     809 + 3b2
    4912      ggg        ggf001     ggf + 001
    7425     18bd       24e166g     24e + 166g
    9280     1f1f       39b1b94     39b + 1b94
   16705     36db       b992c42     b99 + 2c42
   20736     43cd      10de32fg    10de + 32fg
   30016     61eb      23593f92    2359 + 3f92
   36801     785d      351e433g    351e + 433g
   37440     7a96      37144382    3714 + 4382
   46081     967b      52g94382    52g9 + 4382
   46720     98b4      5575433g    5575 + 433g
   53505     af26      6ga43f92    6ga4 + 3f92
   62785     cd44      9a5532fg    9a55 + 32fg
   66816     da36      aeg42c42    aeg4 + 2c42
   74241     f1f2      d75f1b94    d75f + 1b94
   76096     f854      e1f5166g    e1f5 + 166g
   83520     gggg      gggf0001    gggf + 0001
  266224    33334     a2c52a07g    a2c5 + 2a07g
 1153633    ddddd    b3d5e2a07g   b3d5e + 2a07g
 1334529    fgacc    f0540f1a78    f054 + 0f1a78
 1419856    ggggg    ggggf00001   ggggf + 00001
 1787968   146fca   19g4c12dg7f   19g4c + 12dg7f
 3122497   236985   4e3be1f95d8   4e3be + 1f95d8
 3773952   2b32b3   711cb2420f9   711cb + 2420f9
 4243968   2gde03   8fegb27eg09   8fegb + 27eg09
 5108481   3a2d6f   cg10b2e3c64   cg10b + 2e3c64
 5561920   3fa16d   f5eae3043cg   f5eae + 3043cg
 6031936   443ccd  110dde332ffg  110dde + 332ffg
 6896449   4e9c28  16a10c37gb1d  16a10c + 37gb1d
 7435233   54067b  1a72g93aa382  1a72g9 + 3aa382
 8017920   5aggb6  1ef1d43d1ef2  1ef1d4 + 3d1ef2
 9223201   687534  2835c5403g7g  2835c5 + 403g7g
 9805888   6f6f6g  2dbe3f41c131  2dbe3f + 41c131
11140416   7e692a  3a997c43dgbf  3a997c + 43dgbf
11209185   7f391e  3b58d543f059  3b58d5 + 43f059
12928384   91d7f3  4ef79b43f059  4ef79b + 43f059
12997153   92a7e7  4fd82943dgbf  4fd829 + 43dgbf
14331681   a1a1a1  5gf07041c131  5gf070 + 41c131
14914368   a89bdd  685c5e403g7g  685c5e + 403g7g
16119649   b6005b  79f2793d1ef2  79f279 + 3d1ef2
16702336   bcga96  8267143aa382  826714 + 3aa382
17241120   c274e9  8b7acd37gb1d  8b7acd + 37gb1d
18105633   ccd444  99a555332ffg  99a555 + 332ffg
18575649   d16fa4  a12be53043cg  a12be5 + 3043cg
19029088   d6e3a2  a9a83f2e3c64  a9a83f + 2e3c64
19893601   e032ge  b953g527eg09  b953g5 + 27eg09
20363617   e5de5e  c1bd752420f9  c1bd75 + 2420f9
21015072   eda78c  cf11c41f95d8  cf11c4 + 1f95d8
22349601   fca147  e9d1d912dg7f  e9d1d9 + 12dg7f
22803040   g10645  f2fcde0f1a78  f2fcde + 0f1a78
24137568   gggggg  gggggf000001  gggggf + 000001

XPL0

Since integers are only 32 bits (there is no long integer), floating point is used to get the extra precision needed to calculate Kaprekar numbers up to 1,000,000. Floating point (double) provides 15 decimal digits of precision.

include c:\cxpl\codes;  \intrinsic 'code' declarations

func Kaprekar(N, B);    \Returns 'true' if N is a Kaprekar number in base B
int  N, B;
real N2, D; int Q, R;
[N2:= sq(float(N));                     \N squared
D:= float(B);                           \(divider)
loop    [Q:= fix(N2/D - Mod(N2,1.));    \get left part (quotient)
        R:= fix(Mod(N2,D));             \get right part (remainder)
        if Q=0 then return false;
        if Q+R=N & R#0 then return true;
        D:= D * float(B);
        ];
];

int N, C;
[Format(1,0);           \show one place before decimal point and none after it
RlOut(0, 1.);           \show Kaprekar numbers less than ten thousand
for N:= 2 to 10_000-1 do
        if Kaprekar(N, 10) then
                [Text(0, " ");  IntOut(0, N)];
CrLf(0);
C:= 1;                  \show count of Kaprekar numbers less than one million
for N:= 2 to 1_000_000-1 do
        if Kaprekar(N, 10) then C:= C+1;
IntOut(0, C);
CrLf(0);
RlOut(0, 1.);           \show Kaprekar numbers less than one million in base 17
for N:= 2 to 1_000_000-1 do
        if Kaprekar(N, 17) then
                [Text(0, " ");  IntOut(0, N)];
CrLf(0);
]
Output:
1 9 45 55 99 297 703 999 2223 2728 4879 4950 5050 5292 7272 7777 9999
54
1 16 64 225 288 1536 3377 4912 7425 9280 16705 20736 30016 36801 37440 46081 46720 53505 62785 66816 74241 76096 83520 266224

Yabasic

Translation of: BBC BASIC
clear screen
n = 0
FOR i = 1 TO 999999
    IF FNkaprekar(i) THEN
	n = n + 1
	IF i < 100001 PRINT n, ": ", i
    ENDIF
NEXT i
PRINT "Total Kaprekar numbers under 1,000,000 = ", n
END

sub FNkaprekar(n)
    LOCAL s, t
	
    s = n^2
    t = 10^(INT(LOG(s)) + 1)
    do
	t=t/10
	IF t<=n break
	IF s-n = INT(s/t)*(t-1) return TRUE
    loop
    return (n=1)
end sub

zkl

Translation of: D
fcn isKaprekarB(n,b=10){
   powr:=n*n;
   r:=l:=0; tens:=b;
   while(r<n){
      r = powr % tens;
      l = powr / tens;
      if (r and (l + r == n)) return(True);
      tens *= b;
   }
   return(False);
}
println("Kaprekar number <= 10,000:\n",
   [1..].filter(T(isKaprekarB, fcn(n){ if(n>=10000) Void.Stop else True })));

rc:=Ref(0);
[1 .. 0d1_000_000].pump(rc.inc,isKaprekarB,Void.Filter); // if(filter) rc++ 
rc.value.println(" Kaprekar numbers are less than 1,000,000");  // 54

kbs:=[1..].filter(T(isKaprekarB.fp1(17),
                  fcn(n){ if(n>=0d1_000_000) Void.Stop else True }));
Utils.zipWith(fcn(k,n){ "%3d: %7d == %.17B".fmt(n,k,k).println() },kbs,[1..]);
Output:
Kaprekar number <= 10,000:
L(1,9,45,55,99,297,703,999,2223,2728,4879,4950,5050,5292,7272,7777,9999)

54 Kaprekar numbers are less than 1,000,000

  1:       1 == 1
  2:      16 == g
  3:      64 == 3d
  4:     225 == d4
  5:     288 == gg
  6:    1536 == 556
  7:    3377 == bbb
  8:    4912 == ggg
  9:    7425 == 18bd
 10:    9280 == 1f1f
 11:   16705 == 36db
 12:   20736 == 43cd
 13:   30016 == 61eb
 14:   36801 == 785d
 15:   37440 == 7a96
 16:   46081 == 967b
 17:   46720 == 98b4
 18:   53505 == af26
 19:   62785 == cd44
 20:   66816 == da36
 21:   74241 == f1f2
 22:   76096 == f854
 23:   83520 == gggg
 24:  266224 == 33334