The magic number is 6174

[kevin]

Impress your friends with your magical mind reading ability with this code

When run, input any 4 digit number. The only stipulation is that it must include at least 2 different digits.

It then takes the number, sorts the digits in both ascending and descending order, subtracts one from the other,
and then within 6 cycles (I think the maximum is 6), it will arrive at the answer 6174. 

Edit - amended code now allows user to rerun the program

Code:

'With thanks to Johnno for supplying the sorting algorhythm a while ago.
visible screen_w = 1024,screen_h = 768
'Open a window
set window "6174",screen_w,screen_h
'enable double buffering
set redraw off
visible start_number
visible start = []
visible number1
visible number2
visible answer_number = 0
visible first_run = true
visible numElements = 4 ' 4 digits
visible runs = []
##############################################################################################
do
'clear the screen
set color 255,255,255
cls
set color 0,0,0
if first_run = true
    set caret 100,100;set justification left
    write "ENTER ANY 4 DIGIT NUMBER AND PRESS RETURN";wln
    write "THE NUMBER MUST INCLUDE AT LEAST 2 DIFFERENT DIGITS";wln
    start_number = rln(4, TYPE_NUMBER)
endif
if first_run = true
    start = []
    start[0] = int(mid(start_number,0))
    start[1] = int(mid(start_number,1))
    start[2] = int(mid(start_number,2))
    start[3] = int(mid(start_number,3))
    first_run = false
else
    start = []
    start[0] = int(mid(answer_number,0))
    start[1] = int(mid(answer_number,1))
    start[2] = int(mid(answer_number,2))
    start[3] = int(mid(answer_number,3)) 
endif     
if answer_number <>  6174
    set color 255,255,255
    cls
    set color 0,0,0
    process_number(start)
    wait 2000 'this is not necessary - just for "dramatic" effect
else
    write "Press R to start again";wln
    write "======================"
    if keydown(KEY_R)
        start_number = unset
        answer_number = unset
        runs = []
        first_run = true
    endif   
endif
if sizeof(runs ) > 0
set color 0,0,0
set caret 20,20;set justification left
write "Number that you chose =              " + start_number  ;wln;wln
for r = 0 to sizeof(runs) - 1
    write "Number above sorted in descending order is " + runs[r][0];wln
    write "Number above sorted in asccending order is " + runs[r][1];wln;wln
    write "Subtract one from the other is             " + runs[r][2];wln
    write "------------------------------------------------";wln
next
endif
'copy back buffer to the screen
redraw
'cap FPS to 60
fwait 60
until keydown(KEY_ESCAPE)
#########################################################################################
function process_number(table)
'// Main Bubble Sort
for i = 0 to numElements - 2
    for j = 0 to numElements - i - 2
        if start[j] < start[j+1] ' descending sort
            swapValues(j, j+1,start)
        endif
    next
next
number1 = int(start[0]* 1000) + int(start[1])* 100 + 
                int(start[2])* 10 + int(start[3])

for i = 0 to numElements - 2
    for j = 0 to numElements - i - 2
        if table[j] > table[j+1] ' ascending sort
            swapValues(j, j+1,table)
        endif
    next
next

number2 = int(start[0])* 1000 + int(start[1])* 100 + 
                int(start[2])* 10 + int(start[3])
               
answer_number = number1 - number2               
runs[sizeof(runs)] = [number1,number2,answer_number]
endfunc ' =========================
function swapValues(a, b,table1)
    tmp = table1[a]
    table1[a] = table1[b]
    table1[b] = tmp
endfunc

[Marcus]

Haha, fun program

[johnno56]

Very clever! Nicely done!

Hmm... I provided the bubble sort routine? Obviously 'your' memory is better than mine. lol If I did, then you're welcome Bruce.

[kevin]

Thanks both - 6174 is better known as Kaprekar's constant ..... I really cheated by implying ignorance of this.

Johnno, you made this post, which contains numerous sorting routines, which are so useful - I have added them to my library of code snippets - I would recommend it to all......

https://www.naalaa.com/forum/thread-303.html

[1micha.elok]

Impress your friends with your magical mind reading ability with this code

When run, input any 4 digit number. The only stipulation is that it must include at least 2 different digits.

It then takes the number, sorts the digits in both ascending and descending order, subtracts one from the other,
and then within 6 cycles (I think the maximum is 6), it will arrive at the answer 6174. 
...

Thank you for sharing your implementation of the 6174 (Kaprekar's constant) algorithm - it's very helpful ! Just to confirm for the process to work correctly, the starting 4 digit number must contain at least two different digits. Would the following validation logic to be an appropriate way to check this requirement ?

Code:

'Check at least two distinct digits
write "ENTER ANY 4 DIGIT NUMBER AND PRESS RETURN";wln
write "THE NUMBER MUST INCLUDE AT LEAST 2 DIFFERENT DIGITS";wln

'rln(maxChars, type)...4 maxChars has no effect in console mode ?
s = rln(4, TYPE_NUMBER)

d0 = mid(s, 0, 1)
d1 = mid(s, 1, 1)
d2 = mid(s, 2, 1)
d3 = mid(s, 3, 1)
all_same = (d0 = d1) and (d1 = d2) and (d2 = d3)
       
if all_same
  pln "Invalid: all digits identical. Try again."
else
  pln "Valid"
endif

system "pause"

[kevin]

Yes, a great solution for checking for correct input. I can see that you have noted that "4 maxChars has no effect in console mode ", so you would also need to check that 4 digits had been entered, as it currently allows less than 4, and also more than 4 if the first 4 digits are different. I appreciate that my one also allows less than 4 digits, however, it still runs ok, as it assumes that the missing digits are zero.

An alternative validation would be to allow the first calculation (sort descending, sort ascending, and subtract the first from the second) to run. If the result is zero, then the user input must have been 4 digits the same.

All the best - Kevin.