Sudoku solver 8th

\
\  Simple backtracking Sudoku solver for the 8th programming language
\

\ Sub-board window for the given board index
[ 00, 00, 00, 01, 01, 01, 02, 02, 02,
  00, 00, 00, 01, 01, 01, 02, 02, 02,
  00, 00, 00, 01, 01, 01, 02, 02, 02,
  03, 03, 03, 04, 04, 04, 05, 05, 05,
  03, 03, 03, 04, 04, 04, 05, 05, 05,
  03, 03, 03, 04, 04, 04, 05, 05, 05,
  06, 06, 06, 07, 07, 07, 08, 08, 08,
  06, 06, 06, 07, 07, 07, 08, 08, 08,
  06, 06, 06, 07, 07, 07, 08, 08, 08
] ( swap a:_@ ) curry: window?  \ n -- n

\ Sub-board indices for the given window
[
  [00,01,02,09,10,11,18,19,20],
  [03,04,05,12,13,14,21,22,23],
  [06,07,08,15,16,17,24,25,26],
  [27,28,29,36,37,38,45,46,47],
  [30,31,32,39,40,41,48,49,50],
  [33,34,35,42,43,44,51,52,53],
  [54,55,56,63,64,65,72,73,74],
  [57,58,59,66,67,68,75,76,77],
  [60,61,62,69,70,71,78,79,80]
] ( swap a:_@ a:_@ ) curry: sub?  \ a n -- a

[
  [0,1,2,3,4,5,6,7,8],
  [9,10,11,12,13,14,15,16,17],
  [18,19,20,21,22,23,24,25,26],
  [27,28,29,30,31,32,33,34,35],
  [36,37,38,39,40,41,42,43,44],
  [45,46,47,48,49,50,51,52,53],
  [54,55,56,57,58,59,60,61,62],
  [63,64,65,66,67,68,69,70,71],
  [72,73,74,75,76,77,78,79,80]
] ( swap a:_@ a:_@ ) curry: row?  \ a n -- a

[
  [0,9,18,27,36,45,54,63],
  [1,10,19,28,37,46,55,64,73],
  [2,11,20,29,38,47,56,65,74],
  [3,12,21,30,39,48,57,66,75],
  [4,13,22,31,40,49,58,67,76],
  [5,14,23,32,41,50,59,68,77],
  [6,15,24,33,42,51,60,69,78],
  [7,16,25,34,43,52,61,70,79],
  [8,17,26,35,44,53,62,71,80]
] ( swap a:_@ a:_@ ) curry: col?  \ a n -- a

: trailing-zero-bits  \ n -- n
  32 >r
  dup n:neg n:band
  dup if -1 n:r+ then
  dup x0000ffff n:band if -16 n:r+ then
  dup x00ff00ff n:band if -8 n:r+ then
  dup x0f0f0f0f n:band if -4 n:r+ then
  dup x33333333 n:band if -2 n:r+ then
  x55555555 n:band if -1 n:r+ then
  r> ;

\ Bit number presentations
a:new 0 a:push ( 1 swap n:shl a:push ) 0 8 loop
( swap a:_@ ) curry: posbit?

: search  \ n -- n n | n null
  dup trailing-zero-bits dup 8 n:> if
    drop null
  then ;

: b-xor  \ n n -- n
  n:bxor 511 n:band ;

: b-not  \ n n -- n
  n:bnot 511 n:band ;

: b-any  \ a -- n
  ' n:bor 0 a:reduce ;

a:new 0 args "Give Sudoku text file as param" thrownull
f:slurp "Cannot read file" thrownull >s "\n" "" s:replace "" s:/
' >n a:map ( posbit? "Bad data" thrownull a:push ) a:each! drop constant board

: display-board
  board ( search nip -1 ?: n:1+ ) a:map
  "+-----+-----+-----+\n"
  "|%d %d %d|%d %d %d|%d %d %d|\n" s:+
  "|%d %d %d|%d %d %d|%d %d %d|\n" s:+
  "|%d %d %d|%d %d %d|%d %d %d|\n" s:+
  "+-----+-----+-----+\n" s:+
  "|%d %d %d|%d %d %d|%d %d %d|\n" s:+
  "|%d %d %d|%d %d %d|%d %d %d|\n" s:+
  "|%d %d %d|%d %d %d|%d %d %d|\n" s:+
  "+-----+-----+-----+\n" s:+
  "|%d %d %d|%d %d %d|%d %d %d|\n" s:+
  "|%d %d %d|%d %d %d|%d %d %d|\n" s:+
  "|%d %d %d|%d %d %d|%d %d %d|\n" s:+
  "+-----+-----+-----+\n" s:+
  s:strfmt . ;

\ Store move history
a:new constant history

\ Possible numbers for a cell
: candidates?  \ n -- n
  dup dup 9 n:/ n:int swap 9 n:mod \ row col
  board swap col? b-any
  board rot row? b-any
  n:bor
  board rot window? sub? b-any
  n:bor
  b-not ;

\ If found:     -- n T
\ If not found: -- F
: find-free-cell
  false board
  ( !if
      nip true break
    else
      drop
    then ) a:each drop ;

: validate \ -- T
  true
  board
  ( dup -rot a:@ swap 2 pick 0 a:! 2 pick candidates? 2 pick n:= if
      -rot a:!
    else
      3drop
      false swap
      break
    then ) 0 80 loop drop ;

: solve  \ -- T
  repeat
    find-free-cell if
      dup candidates?
      repeat
        search null? if
          drop board -rot a:! drop
          history a:len !if
            drop false ;;
          then
          a:pop nip
          a:open
        else
          n:1+ posbit? dup
          board 4 pick rot a:! drop
          b-xor
          2 a:close
          history swap a:push drop
          break
        then
      again
    else
      validate break
    then
  again ;

: app:main
  "Sudoku puzzle:\n" .
  display-board cr
  solve if
    "Sudoku solved:\n" .
    display-board
  else
    "No solution!\n" .
  then ;