\ SU.f
\ sudoku solver program by Doug Dillon 15apr2006
\ written in SwiftForth
\ type 'su' to find one solution, 'su' to continue with next
\ type 'sus' to find all solutions
\ type '0 to showall' to suppress output on each iteration (speeds up)
\ type 'suinit1' or 'suinit2' or 'suinit3' to initialize

decimal
create sua 81 cells allot
: v ( index--adr) cells sua + ;

$40000 constant perm    \ for 'permanent' entry

\ define 2-bit fields
create bittable 0 , $1 , $4 , $10 , $40 , $100 , $400 , $1000 , $4000 , $10000 ,
: n>b ( n--bit) ( 0 max 9 min) cells bittable + @ ;
: b>n ( bit--n) 9 0 do  dup 1 and if drop i 1+ leave then 2/ 2/ loop ;
: .bs ( bits--) 9 0 do dup 1 and if i 1+ . then 2/ 2/ loop drop ;
: !su ( ..--) 0 80 do  n>b dup if perm + then  i v !  -1 +loop ;

\ 'bright' and 'normal' set font color attributes
: .nsu ( n--) base @ decimal swap
    dup b>n swap perm > if bright 1 .r normal else 1 .r then
    base ! ;
: .su ( --) 81 0 do
    i 3 mod 0= if
        i 9 mod 0= if
            i 27 = if cr ." -----+-----+-----" then
            i 54 = if cr ." -----+-----+-----" then
            cr then
        i 9 mod 3 = if ." |" then
        i 9 mod 6 = if ." |" then
        else space then
    i v @ .nsu  loop ;

\ rbc row,blk,col for each cell
\ 111 112 113  124 125 126  137 138 139
\ 211 212 213  224 225 226  237 238 239
\ 311 312 313  324 325 326  337 338 339
\
\ 441 442 443  454 455 456  467 468 469
\ 541 542 543  554 555 556  567 568 569
\ 641 642 643  654 655 656  667 668 669
\
\ 771 772 773  784 785 786  797 798 799
\ 871 872 873  884 885 886  897 898 899
\ 971 972 973  984 985 986  997 998 999

: v0 ( index--n) v @ ;     \ fetch number from cell
: v1 ( n index--n) v @ + ; \ sum bit fields

\ row tests - return sums of each 2-bit field
: r1 ( --n) 00 v0 01 v1 02 v1 03 v1 04 v1 05 v1 06 v1 07 v1 08 v1 ;
: r2 ( --n) 09 v0 10 v1 11 v1 12 v1 13 v1 14 v1 15 v1 16 v1 17 v1 ;
: r3 ( --n) 18 v0 19 v1 20 v1 21 v1 22 v1 23 v1 24 v1 25 v1 26 v1 ;
: r4 ( --n) 27 v0 28 v1 29 v1 30 v1 31 v1 32 v1 33 v1 34 v1 35 v1 ;
: r5 ( --n) 36 v0 37 v1 38 v1 39 v1 40 v1 41 v1 42 v1 43 v1 44 v1 ;
: r6 ( --n) 45 v0 46 v1 47 v1 48 v1 49 v1 50 v1 51 v1 52 v1 53 v1 ;
: r7 ( --n) 54 v0 55 v1 56 v1 57 v1 58 v1 59 v1 60 v1 61 v1 62 v1 ;
: r8 ( --n) 63 v0 64 v1 65 v1 66 v1 67 v1 68 v1 69 v1 70 v1 71 v1 ;
: r9 ( --n) 72 v0 73 v1 74 v1 75 v1 76 v1 77 v1 78 v1 79 v1 80 v1 ;

\ block tests
: b1 ( --n) 00 v0 01 v1 02 v1 09 v1 10 v1 11 v1 18 v1 19 v1 20 v1 ;
: b2 ( --n) 03 v0 04 v1 05 v1 12 v1 13 v1 14 v1 21 v1 22 v1 23 v1 ;
: b3 ( --n) 06 v0 07 v1 08 v1 15 v1 16 v1 17 v1 24 v1 25 v1 26 v1 ;
: b4 ( --n) 27 v0 28 v1 29 v1 36 v1 37 v1 38 v1 45 v1 46 v1 47 v1 ;
: b5 ( --n) 30 v0 31 v1 32 v1 39 v1 40 v1 41 v1 48 v1 49 v1 50 v1 ;
: b6 ( --n) 33 v0 34 v1 35 v1 42 v1 43 v1 44 v1 51 v1 52 v1 53 v1 ;
: b7 ( --n) 54 v0 55 v1 56 v1 63 v1 64 v1 65 v1 72 v1 73 v1 74 v1 ;
: b8 ( --n) 57 v0 58 v1 59 v1 66 v1 67 v1 68 v1 75 v1 76 v1 77 v1 ;
: b9 ( --n) 60 v0 61 v1 62 v1 69 v1 70 v1 71 v1 78 v1 79 v1 80 v1 ;

\ column tests
: c1 ( --n) 00 v0 09 v1 18 v1 27 v1 36 v1 45 v1 54 v1 63 v1 72 v1 ;
: c2 ( --n) 01 v0 10 v1 19 v1 28 v1 37 v1 46 v1 55 v1 64 v1 73 v1 ;
: c3 ( --n) 02 v0 11 v1 20 v1 29 v1 38 v1 47 v1 56 v1 65 v1 74 v1 ;
: c4 ( --n) 03 v0 12 v1 21 v1 30 v1 39 v1 48 v1 57 v1 66 v1 75 v1 ;
: c5 ( --n) 04 v0 13 v1 22 v1 31 v1 40 v1 49 v1 58 v1 67 v1 76 v1 ;
: c6 ( --n) 05 v0 14 v1 23 v1 32 v1 41 v1 50 v1 59 v1 68 v1 77 v1 ;
: c7 ( --n) 06 v0 15 v1 24 v1 33 v1 42 v1 51 v1 60 v1 69 v1 78 v1 ;
: c8 ( --n) 07 v0 16 v1 25 v1 34 v1 43 v1 52 v1 61 v1 70 v1 79 v1 ;
: c9 ( --n) 08 v0 17 v1 26 v1 35 v1 44 v1 53 v1 62 v1 71 v1 80 v1 ;

\ row,block,column for each of the 81 cells
: l00 ( --n n n)  r1 b1 c1 ;
: l01 ( --n n n)  r1 b1 c2 ;
: l02 ( --n n n)  r1 b1 c3 ;
: l03 ( --n n n)  r1 b2 c4 ;
: l04 ( --n n n)  r1 b2 c5 ;
: l05 ( --n n n)  r1 b2 c6 ;
: l06 ( --n n n)  r1 b3 c7 ;
: l07 ( --n n n)  r1 b3 c8 ;
: l08 ( --n n n)  r1 b3 c9 ;
: l09 ( --n n n)  r2 b1 c1 ;
: l10 ( --n n n)  r2 b1 c2 ;
: l11 ( --n n n)  r2 b1 c3 ;
: l12 ( --n n n)  r2 b2 c4 ;
: l13 ( --n n n)  r2 b2 c5 ;
: l14 ( --n n n)  r2 b2 c6 ;
: l15 ( --n n n)  r2 b3 c7 ;
: l16 ( --n n n)  r2 b3 c8 ;
: l17 ( --n n n)  r2 b3 c9 ;
: l18 ( --n n n)  r3 b1 c1 ;
: l19 ( --n n n)  r3 b1 c2 ;
: l20 ( --n n n)  r3 b1 c3 ;
: l21 ( --n n n)  r3 b2 c4 ;
: l22 ( --n n n)  r3 b2 c5 ;
: l23 ( --n n n)  r3 b2 c6 ;
: l24 ( --n n n)  r3 b3 c7 ;
: l25 ( --n n n)  r3 b3 c8 ;
: l26 ( --n n n)  r3 b3 c9 ;
: l27 ( --n n n)  r4 b4 c1 ;
: l28 ( --n n n)  r4 b4 c2 ;
: l29 ( --n n n)  r4 b4 c3 ;
: l30 ( --n n n)  r4 b5 c4 ;
: l31 ( --n n n)  r4 b5 c5 ;
: l32 ( --n n n)  r4 b5 c6 ;
: l33 ( --n n n)  r4 b6 c7 ;
: l34 ( --n n n)  r4 b6 c8 ;
: l35 ( --n n n)  r4 b6 c9 ;
: l36 ( --n n n)  r5 b4 c1 ;
: l37 ( --n n n)  r5 b4 c2 ;
: l38 ( --n n n)  r5 b4 c3 ;
: l39 ( --n n n)  r5 b5 c4 ;
: l40 ( --n n n)  r5 b5 c5 ;
: l41 ( --n n n)  r5 b5 c6 ;
: l42 ( --n n n)  r5 b6 c7 ;
: l43 ( --n n n)  r5 b6 c8 ;
: l44 ( --n n n)  r5 b6 c9 ;
: l45 ( --n n n)  r6 b4 c1 ;
: l46 ( --n n n)  r6 b4 c2 ;
: l47 ( --n n n)  r6 b4 c3 ;
: l48 ( --n n n)  r6 b5 c4 ;
: l49 ( --n n n)  r6 b5 c5 ;
: l50 ( --n n n)  r6 b5 c6 ;
: l51 ( --n n n)  r6 b6 c7 ;
: l52 ( --n n n)  r6 b6 c8 ;
: l53 ( --n n n)  r6 b6 c9 ;
: l54 ( --n n n)  r7 b7 c1 ;
: l55 ( --n n n)  r7 b7 c2 ;
: l56 ( --n n n)  r7 b7 c3 ;
: l57 ( --n n n)  r7 b8 c4 ;
: l58 ( --n n n)  r7 b8 c5 ;
: l59 ( --n n n)  r7 b8 c6 ;
: l60 ( --n n n)  r7 b9 c7 ;
: l61 ( --n n n)  r7 b9 c8 ;
: l62 ( --n n n)  r7 b9 c9 ;
: l63 ( --n n n)  r8 b7 c1 ;
: l64 ( --n n n)  r8 b7 c2 ;
: l65 ( --n n n)  r8 b7 c3 ;
: l66 ( --n n n)  r8 b8 c4 ;
: l67 ( --n n n)  r8 b8 c5 ;
: l68 ( --n n n)  r8 b8 c6 ;
: l69 ( --n n n)  r8 b9 c7 ;
: l70 ( --n n n)  r8 b9 c8 ;
: l71 ( --n n n)  r8 b9 c9 ;
: l72 ( --n n n)  r9 b7 c1 ;
: l73 ( --n n n)  r9 b7 c2 ;
: l74 ( --n n n)  r9 b7 c3 ;
: l75 ( --n n n)  r9 b8 c4 ;
: l76 ( --n n n)  r9 b8 c5 ;
: l77 ( --n n n)  r9 b8 c6 ;
: l78 ( --n n n)  r9 b9 c7 ;
: l79 ( --n n n)  r9 b9 c8 ;
: l80 ( --n n n)  r9 b9 c9 ;

create tgetbits     \ execution table for the 81 locations
' l00 , ' l01 , ' l02 , ' l03 , ' l04 , ' l05 , ' l06 , ' l07 , ' l08 ,
' l09 , ' l10 , ' l11 , ' l12 , ' l13 , ' l14 , ' l15 , ' l16 , ' l17 ,
' l18 , ' l19 , ' l20 , ' l21 , ' l22 , ' l23 , ' l24 , ' l25 , ' l26 ,
' l27 , ' l28 , ' l29 , ' l30 , ' l31 , ' l32 , ' l33 , ' l34 , ' l34 ,
' l36 , ' l37 , ' l38 , ' l39 , ' l40 , ' l41 , ' l42 , ' l43 , ' l44 ,
' l45 , ' l46 , ' l47 , ' l48 , ' l49 , ' l50 , ' l51 , ' l52 , ' l53 ,
' l54 , ' l55 , ' l56 , ' l57 , ' l58 , ' l59 , ' l60 , ' l61 , ' l62 ,
' l63 , ' l64 , ' l65 , ' l66 , ' l67 , ' l68 , ' l69 , ' l70 , ' l71 ,
' l72 , ' l73 , ' l74 , ' l75 , ' l76 , ' l77 , ' l78 , ' l79 , ' l80 ,

: getbits ( index--rbits bbits cbits) cells tgetbits + @execute ;

\ if there is a duplicate number, then the bits counted will be 2 or 3.
: badnum? ( n--f) dup 2/ 2/ dup 2/ 2/ dup 2/ 2/ dup 2/ 2/
                  dup 2/ 2/ dup 2/ 2/ dup 2/ 2/ dup 2/ 2/
    or or or or or or or or 2 and ;

: badnumber? ( index--f) \ getbits badnum? swap badnum? or swap badnum? or ;
    getbits or or badnum? ;

\ 0=success, 1=perm, 2=failure, reset to zero
: +count ( indx--indx flg) dup v @ dup perm >=  \ indx bits f
    if drop 1               \ perm=1
    else b>n 1+ ( indx n)
        begin dup 9 >
            if drop 0 over v !  2 true      \ failure=2, exit loop
            else ( indx n) 2dup n>b swap v !
                over badnumber?
                if 1+ false                 \ inc number, try again
                else drop 0 true            \ success=0, exit loop
                then
            then
        until
    then ;

variable sctr 0 sctr !
variable dly 1 dly !
variable ct0
variable ct1
variable ct2
1 value showall
: showstatus ( --) 0 0 at-xy .su space dup .
            ct0 ? ct1 ? ct2 ? sctr ? dly @ ms ;

\ which way to move when perm # is encountered
variable direction  1 direction !

\ can restart with indx after success
: su ( indx--indx) showall if page then
    begin +count case
        0 of 1+ 1 direction ! 1 ct0 +! endof     \ success, inc index
        1 of direction @ + 1 ct1 +! endof        \ perm, add direction to index
        2 of 1- -1 direction ! 1 ct2 +! endof    \ failure, dec index
        dup of ." impossible" abort endof
        endcase
        showall if showstatus then          \ '0 to showall' to speed display
        dup 0 81 within 0=
    until
    dup 81 = if 1- -1 direction ! 1 sctr +!
        showall 0= if showstatus then
        ."  success! " sctr ? then
    dup -1 = if ."  No " sctr @ if ." more " then ." solutions. " then ;

: sus ( indx--indx) page begin su dup -1 = key? or until ;

: suinit1 ( --) 1 direction !   \ 1 solution
    0 sctr ! 0 ct0 ! 0 ct1 ! 0 ct2 !
    0 5 0  0 6 0  0 4 0
    0 0 1  0 0 0  8 0 0
    0 0 2  3 0 9  5 0 0

    0 8 9  5 0 6  4 1 0
    0 0 0  2 0 1  0 0 0
    0 3 4  7 0 8  2 6 0

    0 0 7  1 0 4  6 0 0
    0 0 6  0 0 0  7 0 0
    0 9 0  0 7 0  0 3 0  !su .su 0 ;

: suinit2 ( --) 1 direction !   \ 10,032 solutions
    0 sctr ! 0 ct0 ! 0 ct1 ! 0 ct2 !
    1 2 3  4 5 6  7 8 9
    4 5 6  7 8 9  1 2 3
    7 8 9  1 2 3  4 5 6

    2 1 4  3 6 5  8 9 7
    3 6 5  0 0 0  0 0 0
    0 0 0  0 0 0  0 0 0

    0 0 0  0 0 0  0 0 0
    0 0 0  0 0 0  0 0 0
    0 0 0  0 0 0  0 0 0  !su .su 0 ;

: suinit3 ( --) 1 direction !   \ 64 solutions
    0 sctr ! 0 ct0 ! 0 ct1 ! 0 ct2 !
    0 7 8  0 0 0  1 2 3
    9 0 2  0 0 0  4 5 6
    3 4 0  0 0 0  7 8 9

    0 0 0  0 2 3  0 0 0
    0 0 0  4 5 6  0 0 0
    0 0 0  7 8 0  0 0 0

    1 2 3  0 0 0  6 7 0
    4 5 6  0 0 0  9 0 2
    7 8 9  0 0 0  0 4 5  !su .su 0 ;

suinit1