\  Sudoku Solver in Forth.
\  No special extensions were used.
\  Tested on in win32forth, VFX and Swift (evaluation).
\  No locals were harmed during this experiment.

\  Version: 1900 01092005 - Robert Spykerman
\  Modifier:  David N. Williams
\  Email: robspyke_nospam@iprimus_no_spam.com.au
\         (delete the obvious)

\ 4tH version: 2005,2022 J.L. Bezemer

include lib/interprt.4th
include lib/istype.4th
include lib/argopen.4th

\  ---------------------
\  Variables
\  ---------------------

81 string sudokugrid
9 array sudoku_row
9 array sudoku_col
9 array sudoku_box

\  -------------
\  4tH interface
\  -------------

: >grid                                ( n2 a1 n1 -- n3)
  rot dup >r 9 chars * sudokugrid + dup >r swap
  0 do                                 ( a1 a2)
    over i chars + c@ dup is-digit     ( a1 a2 c f)
    if [char] 0 - over c! char+ else drop then
  loop                                 ( a1 a2)
  nip r> - 9 /  r> +                   ( n3)
;

0
s" 090004007" >grid
s" 000007900" >grid
s" 800000000" >grid
s" 405800000" >grid
s" 300000002" >grid
s" 000009706" >grid
s" 000000004" >grid
s" 003500000" >grid
s" 200600080" >grid
drop

\  ---------------------
\  Logic
\  ---------------------
\  Basically :
\     Grid is parsed. All numbers are put into sets, which are
\     implemented as bitmaps (sudoku_row, sudoku_col, sudoku_box)
\     which represent sets of numbers in each row, column, box.
\     only one specific instance of a number can exist in a
\     particular set.

\     SOLVER is recursively called
\     SOLVER looks for the next best guess using FINDNEXTSPACE
\     tries this trail down... if fails, backtracks... and tries
\     again.


\ Grid Related

: xy 9 * + ;                           \  x y -- offset ;
: getrow 9 / ;
: getcol 9 mod ;
: getbox dup getrow 3 / 3 * swap getcol 3 / + ;

\ Puts and gets numbers from/to grid only
: setnumber sudokugrid + c! ;          \ n position --
: getnumber sudokugrid + c@ ;

: cleargrid sudokugrid 81 bounds do 0 i c! loop ;

\ --------------
\ Set related: sets are sudoku_row, sudoku_col, sudoku_box

\ ie x y --   ;  adds x into bitmap y
: addbits_row cells sudoku_row + dup @ rot 1 swap lshift or swap ! ;
: addbits_col cells sudoku_col + dup @ rot 1 swap lshift or swap ! ;
: addbits_box cells sudoku_box + dup @ rot 1 swap lshift or swap ! ;

\ ie x y --  ; remove number x from bitmap y
: removebits_row cells sudoku_row + dup @ rot 1 swap lshift invert and swap ! ;
: removebits_col cells sudoku_col + dup @ rot 1 swap lshift invert and swap ! ;
: removebits_box cells sudoku_box + dup @ rot 1 swap lshift invert and swap ! ;

\ clears all bitsmaps to 0
: clearbitmaps 9 0 do i cells
                     0 over sudoku_row + !
                     0 over sudoku_col + !
                     0 swap sudoku_box + !
           loop ;

\ Adds number to grid and sets
: addnumber                            \ number position --
    2dup setnumber
    2dup getrow addbits_row
    2dup getcol addbits_col
         getbox addbits_box
;

\ Remove number from grid, and sets
: removenumber                         \ position --
    dup getnumber swap
    2dup getrow removebits_row
    2dup getcol removebits_col
    2dup getbox removebits_box
    nip 0 swap setnumber
;

\ gets bitmap at position, ie
\ position -- bitmap

: getrow_bits getrow cells sudoku_row + @ ;
: getcol_bits getcol cells sudoku_col + @ ;
: getbox_bits getbox cells sudoku_box + @ ;

\ position -- composite bitmap  (or'ed)
: getbits
    dup getrow_bits
    over getcol_bits
    rot getbox_bits or or
;

\ algorithm from c.l.f circa 1995 ? Will Baden
: countbits    ( number -- bits )
        [HEX] DUP  55555555 AND  SWAP  1 RSHIFT  55555555 AND  +
              DUP  33333333 AND  SWAP  2 RSHIFT  33333333 AND  +
              DUP  0F0F0F0F AND  SWAP  4 RSHIFT  0F0F0F0F AND  +
        [DECIMAL] 255 MOD
;

\ Try tests a number in a said position of grid
\ Returns true if it's possible, else false.
: try                                  \ number position -- true/false
      getbits 1 rot lshift and 0=
;

\ --------------
: parsegrid                            \ Parses Grid to fill sets.. Run before solver.
   sudokugrid                          \ to ensure all numbers are parsed into sets/bitmaps
   81 0 do
     dup i + c@
       dup if
         dup i try if
           i addnumber
         else
           unloop drop drop FALSE exit
         then
       else
         drop
       then
   loop
   drop
   TRUE
;

\ Morespaces? manually checks for spaces ...
\ Obviously this can be optimised to a count var, done initially
\ Any additions/subtractions made to the grid could decrement
\ a 'spaces' variable.

: morespaces?
     0  sudokugrid 81 bounds do i c@  0= if 1+ then loop ;

: findnextmove                         \  -- n ; n = index next item, if -1 finished.

   -1  10                              \  index  prev_possibilities  --
                                       \  err... yeah... local variables, kind of...

   81 0 do
      i sudokugrid + c@ 0= IF
             i getbits countbits 9 swap -

             \ get bitmap and see how many possibilities
             \ stack diagram:
             \ index prev_possibilities  new_possiblities --

             2dup > if
                                       \ if new_possibilities < prev_possibilities...
                 nip nip i swap
                                       \ new_index new_possibilies --

             else                      \ else prev_possibilities < new possibilities, so:

                 drop                  \ new_index new_possibilies --

             then
      THEN
   loop
   drop
;

\ findnextmove returns index of best next guess OR returns -1
\ if no more guesses. You then have to check to see if there are
\ spaces left on the board unoccupied. If this is the case, you
\ need to back up the recursion and try again.

: solver
     findnextmove
         dup 0< if
             morespaces? if
                drop false exit
             else
                drop true exit
             then
         then

     10 1 do
        i over try if
           i over addnumber
           recurse  if
                drop unloop TRUE EXIT
           else
                dup removenumber
           then
        then
     loop

     drop FALSE
;

\ SOLVER

: startsolving
   clearbitmaps                        \ reparse bitmaps and reparse grid
   parsegrid                           \ just in case..
   solver
   AND
;

\  ---------------------
\  Display Grid
\  ---------------------

\ Prints grid nicely

: .sudokugrid
  CR CR
  sudokugrid
  81 0 do
    dup i + c@ .
    i 1+
      dup 3 mod 0= if
         dup 9 mod 0= if
            CR
            dup 27 mod 0= if
              dup 81 < if ." ------+-------+------" CR then
            then
         else
           ." | "
         then
      then
    drop
  loop
  drop
  CR
;

\  ---------------------
\  Higher Level Words
\  ---------------------

: checkifoccupied                      ( offset -- t/f)
    sudokugrid + c@
;

: add                                  ( n x y --)
    xy 2dup
      dup checkifoccupied if
        dup removenumber
      then
    try if
      addnumber
      .sudokugrid
    else
      CR ." Not a valid move. " CR
      2drop
    then
;

: rm
    xy removenumber
    .sudokugrid
;

: clearit
    cleargrid
    clearbitmaps
    .sudokugrid
;

: solveit
  CR
  startsolving
  if
    ." Solution found!" CR .sudokugrid
  else
    ." No solution found!" CR CR
  then
;

: showit .sudokugrid ;

\ Print help menu
: help
  CR
  ." Type clearit     ; to clear grid " CR
  ."      1-9 x y add ; to add 1-9 to grid at x y (0 based) " CR
  ."      x y rm      ; to remove number at x y " CR
  ."      showit      ; redisplay grid " CR
  ."      solveit     ; to solve " CR
  ."      help        ; for help " CR
  CR
;

\  ---------------------
\  Execution starts here
\  ---------------------

: godoit
    clearbitmaps
    parsegrid if
      CR ." Grid valid!"
    else
      CR ." Warning: grid invalid!"
    then
    .sudokugrid
    help
;

\  -------------
\  4tH interface
\  -------------

: read-sudoku
  input 1 arg-open 0
  begin dup 9 < while refill while 0 parse >grid repeat
  drop close
;

: bye quit ;

create wordlist                        \ dictionary
  ," clearit" ' clearit ,
  ," add"     ' add ,
  ," rm"      ' rm ,
  ," showit"  ' showit ,
  ," solveit" ' solveit ,
  ," quit"    ' bye ,
  ," exit"    ' bye ,
  ," bye"     ' bye ,
  ," q"       ' bye ,
  ," help"    ' help ,
  NULL ,

wordlist to dictionary
:noname ." Unknown command '" type ." '" cr ; is NotFound
                                       \ sudoku interpreter
: sudoku
  argn 1 > if read-sudoku then
  godoit
  begin
    ." OK" cr refill
  while
    ['] interpret catch if ." Error" cr then
  repeat
;

sudoku
