(*
* LANGUAGE : ANS Forth
* PROJECT : Forth Environments
* DESCRIPTION : Sudoku solver
* CATEGORY : Game
* AUTHOR : Marcel Hendrix
* LAST CHANGE : Tuesday, May 05, 2020, 15:35, mhx;
*)

NEEDS -miscutil

REVISION -sudoku "--- Sudoku solver Version 1.00 ---"

PRIVATES

DOC
(*
CONTEST
-------
Go contest: https://codegolf.stackexchange.com/questions/190727/the-fastest-sudoku-solver

DATA STRUCTURE
--------------
Each of the Sudoku's 81 squares belongs to a unique tuple (line, column, box). We can identify
a line | column | box with 4 bits (1..9) , so 12 bits allow to label all squares.
Each of the 81 squares can hold 9 possible numbers, 1 or 2 or .. 9. This suggests
an array[81] of 32-bit entries:

bit: 40 .. 32 | 11 10 9 8 | 7 6 5 4 | 3 2 1 0
data: { d | l | c | b }

We have a list, or better a queue, of candidate entries to position on the board. When Sudoku
starts this is filled from the initial list of occupied squares. Unoccupied squares start out
as $F00xx, with the 12 'xx' bits set to the square's address.

Get the next candidate, place it (set its dth bit and bit 41 to mark it DONE),
then visit all squares that are on the same line or column, or in the same box.
These are entries that match either of the candidate's l, c, or b bits.
When we find such a square we know it CAN'T be occupied by the same number as our candidate,
so we reset the d-th bit in its d-field (decreasing the number of possible numbers there by 1).
If no d-bit is high, RETURN (either an error or recursion unsuccesful).

We will have 9 arrays of 9 square-addresses in the same row, 9 arrays of 9 column-addresses,
and 9 arrays of 9 box-addresses. Therefore, we are done after 27 tests. Dequeue the candidate.

Next we can run run through all d-fields looking for new candidates. These have a single bit
of their d-field set (none set => RETURN). Note that previous candidates are left alone because
they have bit 41 set. Copy these candidates to the queue and restart.

How do we know to stop? We should have 81 entries with bit 41 set and at most one other d-field bit.
What CAN happen is that the queue is empty nut there are a non-zero amount of entries that have
bit 41 unset. In this case we have to recurse / backtrack:
0. make a list of alternatives and point to the first #alternative
1. "push" 81-byte d-bits + #alternative
2. next alternative becomes candidate, call MYSELF
3. if !OK then
"pop" d-bits, inc #alternative, goto 1.
else "drop" d-bits
end
4. ...

We'll try it without backtracking first.

*)
ENDDOC

-- ---------------------
-- Variables
-- ---------------------

0 VALUE longtime PRIVATE
#1000 VALUE #do PRIVATE
0 VALUE #spaces PRIVATE

CREATE xbits PRIVATE #256 DUP * CELLS ALLOT xbits #256 DUP * CELLS CONST-DATA

: INIT-BITS #256 DUP * 0 DO I #bits I xbits []CELL ! LOOP ; INIT-BITS FORGET INIT-BITS

: COUNTBITS ( u -- n ) xbits []CELL @ ; PRIVATE

: rg 9 0 DO PARSE-NAME >FLOAT DROP F>S C, LOOP ; PRIVATE

CREATE grid0
rg 0 9 0 0 0 4 0 0 7
rg 0 0 0 0 0 7 9 0 0
rg 8 0 0 0 0 0 0 0 0

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

rg 0 0 0 0 0 0 0 0 4
rg 0 0 3 5 0 0 0 0 0
rg 2 0 0 6 0 0 0 8 0
," originally 4.36 ms for the computer"

CREATE grid1
rg 0 0 6 0 5 0 0 0 0
rg 0 7 0 0 3 9 1 0 0
rg 0 8 0 0 0 0 0 3 0

rg 0 0 0 0 0 2 5 1 8
rg 0 0 0 0 0 0 0 0 0
rg 7 5 9 8 0 0 0 0 0

rg 0 6 0 0 0 0 0 7 0
rg 0 0 2 5 9 0 0 4 0
rg 0 0 0 0 6 0 3 0 0
," 45 minutes human"

CREATE grid2
rg 9 2 0 0 0 0 0 0 8
rg 0 8 0 0 0 0 0 5 1
rg 0 0 1 5 0 0 3 0 0

rg 0 0 0 9 0 7 8 0 0
rg 0 0 0 0 0 0 0 0 0
rg 0 0 3 6 0 2 0 0 0

rg 0 0 6 0 0 4 7 0 0
rg 5 7 0 0 0 0 0 8 0
rg 8 0 0 0 0 0 0 9 3
," 2 hours human"

CREATE grid3
rg 0 0 0 0 0 3 5 0 0
rg 0 0 0 7 0 0 4 0 0
rg 7 0 3 0 0 6 0 1 0

rg 0 1 0 0 0 5 0 0 6
rg 8 0 0 0 0 0 0 0 2
rg 4 0 0 3 0 0 0 8 0

rg 0 5 0 4 0 0 1 0 8
rg 0 0 8 0 0 9 0 0 0
rg 0 0 9 8 0 0 0 0 0
," 2 hours for a human, maybe impossible"

CREATE grid4
rg 2 0 0 0 3 0 7 0 6
rg 0 0 8 4 0 0 0 0 0
rg 6 0 0 0 9 0 0 3 0

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

rg 0 6 0 0 2 0 0 0 8
rg 0 0 0 0 0 7 4 0 0
rg 3 0 2 0 5 0 0 0 9
," unknown source"

CREATE grid5
rg 9 0 0 0 1 0 6 0 0
rg 0 0 0 8 0 0 0 0 7
rg 6 3 0 0 0 7 2 0 0

rg 0 0 0 0 0 0 5 7 4
rg 0 0 0 2 4 3 0 0 0
rg 0 4 1 0 0 0 0 0 0

rg 0 0 9 6 0 4 8 3 1
rg 4 0 0 0 0 8 0 0 0
rg 0 0 8 0 2 0 0 0 9
," Paul Hsieh's example #1"

CREATE grid6
rg 0 0 9 6 0 0 1 0 0
rg 0 0 0 0 0 0 0 2 4
rg 6 0 0 0 0 2 0 9 0

rg 3 0 0 4 2 0 0 0 0
rg 0 8 0 3 1 0 0 0 7
rg 2 0 4 0 0 0 0 1 8

rg 0 0 0 7 0 4 8 0 2
rg 5 4 0 0 3 0 0 0 1
rg 7 9 0 5 0 0 0 0 0
," Paul Hsieh's example #2"

CREATE grid7
rg 0 5 0 0 0 8 6 0 0
rg 7 0 0 5 4 0 0 0 9
rg 0 1 0 0 6 0 0 0 3

rg 6 0 0 0 0 0 0 0 0
rg 0 3 0 0 0 0 0 8 0
rg 0 0 0 0 0 0 0 0 5

rg 9 0 0 0 3 0 0 1 0
rg 4 0 0 0 7 6 0 0 8
rg 0 0 1 8 0 0 0 7 0
," Paul Hsieh's example #3"

CREATE grid8
rg 0 9 8 0 0 0 0 0 0
rg 0 0 0 0 7 0 0 0 0
rg 0 0 0 0 1 5 0 0 0

rg 1 0 0 0 0 0 0 0 0
rg 0 0 0 2 0 0 0 0 9
rg 0 0 0 9 0 6 0 8 2

rg 0 0 0 0 0 0 0 3 0
rg 5 0 1 0 0 0 0 0 0
rg 0 0 0 4 0 0 0 2 0
," A `minimal' Sudoku (thought impossible for humans)"

CREATE grid9
rg 0 0 1 0 0 0 8 0 0
rg 0 7 0 3 1 0 0 9 0
rg 3 0 0 0 4 5 0 0 7

rg 0 9 0 7 0 0 5 0 0
rg 0 4 2 0 5 0 1 3 0
rg 0 0 3 0 0 9 0 4 0

rg 2 0 0 5 7 0 0 0 4
rg 0 3 0 0 9 1 0 6 0
rg 0 0 4 0 0 0 3 0 0
," Ertl #1"

CREATE grid10
rg 0 6 5 0 0 0 0 0 8
rg 7 0 0 8 6 0 4 0 0
rg 0 0 0 0 2 0 0 0 9

rg 0 4 0 0 0 1 0 0 2
rg 0 0 0 2 0 7 0 0 0
rg 3 0 0 5 0 0 0 7 0

rg 4 0 0 0 5 0 0 0 0
rg 0 0 1 0 7 9 0 0 3
rg 9 0 0 0 0 0 2 6 0
," Ertl #2"

CREATE grid11
rg 0 0 0 0 7 0 9 4 0
rg 0 0 0 0 9 0 0 0 5
rg 3 0 0 0 0 5 0 7 0

rg 0 0 7 4 0 0 1 0 0
rg 4 6 3 0 0 0 0 0 0
rg 0 0 0 0 0 7 0 8 0

rg 8 0 0 0 0 0 0 0 0
rg 7 0 0 0 0 0 0 2 8
rg 0 5 0 2 6 0 0 0 0
," Ertl #3"

CREATE grid12
rg 0 4 6 0 8 0 1 3 0
rg 3 9 0 5 0 6 2 0 7
rg 0 5 0 1 3 7 4 0 0

rg 0 0 0 0 9 1 7 0 0
rg 1 0 0 0 0 0 6 4 0
rg 0 0 0 8 0 0 9 0 2

rg 0 6 8 0 7 0 0 2 0
rg 0 0 5 0 0 3 8 7 0
rg 2 0 7 9 0 0 0 6 0
," Ertl #4"

CREATE grid13
rg 7 0 8 0 3 0 0 0 0
rg 0 9 0 0 2 7 0 0 0
rg 0 2 1 8 0 0 9 7 0

rg 0 0 0 0 0 4 5 8 0
rg 0 0 7 0 0 0 2 0 0
rg 0 5 6 7 0 0 0 0 0

rg 0 1 5 0 0 3 6 2 0
rg 0 0 0 2 6 0 0 3 0
rg 0 0 0 0 5 0 7 0 9
," Ertl #5"

CREATE grid14
rg 6 0 8 9 0 2 0 0 7
rg 0 0 0 0 7 0 9 0 0
rg 7 9 0 0 0 4 0 0 0

rg 5 0 0 0 0 7 3 0 0
rg 4 8 0 0 0 0 0 7 5
rg 0 0 7 6 0 0 0 0 4

rg 0 0 0 2 0 0 0 1 6
rg 0 0 1 0 3 0 0 0 0
rg 2 0 0 4 0 1 5 0 3
," Ertl #6"

CREATE grid15
rg 0 0 0 0 0 0 9 0 0
rg 1 7 0 0 0 5 0 0 2
rg 0 8 0 9 2 1 0 0 7

rg 0 1 0 0 9 0 5 0 0
rg 0 9 0 4 0 2 0 3 0
rg 0 0 4 0 7 0 0 2 0

rg 9 0 0 2 6 7 0 8 0
rg 6 0 0 8 0 0 0 7 1
rg 0 0 8 0 0 0 0 0 0
," Ertl #7"

CREATE grid16
rg 0 9 0 0 0 5 3 0 0
rg 0 0 0 0 2 0 8 0 5
rg 5 0 8 0 0 6 0 7 0

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

rg 0 2 0 6 0 0 4 0 8
rg 4 0 9 0 3 0 0 0 0
rg 0 0 5 1 0 0 0 9 0
," Ertl #8"

CREATE grid17
rg 4 0 0 0 0 3 0 9 0
rg 0 9 0 2 0 5 3 1 0
rg 0 0 0 0 0 6 0 0 2

rg 0 3 1 7 0 0 9 0 0
rg 0 0 0 0 0 0 0 0 0
rg 0 0 5 0 0 1 8 6 0

rg 7 0 0 1 0 0 0 0 0
rg 0 8 3 6 0 4 0 2 0
rg 0 6 0 3 0 0 0 0 4
," Rickman ExtraHard"

: TRANSLATE ( char -- n )
>S
S" 0MAISFORTH" 0 DO C@+ S = IF S> 2DROP I UNLOOP EXIT ENDIF LOOP
S> 2DROP TRUE ABORT" Translate :: invalid character" ; PRIVATE

: xrg 9 0 DO PARSE-NAME DROP C@ TRANSLATE C, LOOP ; PRIVATE

CREATE grid18
xrg 0 0 F I S 0 0 0 A
xrg 0 0 I 0 R 0 0 0 S
xrg 0 0 A 0 0 H 0 0 0

xrg 0 0 M R F T 0 0 0
xrg 0 0 H 0 0 0 0 0 0
xrg T 0 S 0 0 0 0 R 0

xrg 0 0 0 0 0 0 A T I
xrg A 0 0 M 0 0 S 0 0
xrg 0 H 0 O 0 0 M 0 R
," The `breinbreker' Sudoku (Vijgeblad oktober 2006)"

: DECODE ( char1 -- char2 )
>R S" 0MAISFORTH" DROP R> '0' - + C@ ; PRIVATE

: drg CR 9 0 DO I 3 MOD 0= IF 2 SPACES ENDIF
PARSE-NAME DROP C@ DECODE EMIT
LOOP ; PRIVATE

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

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

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

CREATE grid19
rg 5 0 0 1 0 0 3 0 0
rg 7 0 0 6 0 0 0 0 0
rg 0 0 9 0 4 7 6 0 2
rg 0 0 3 0 0 0 0 0 7
rg 0 1 0 0 0 0 0 8 0
rg 2 9 0 0 0 1 4 0 0
rg 8 0 0 0 0 0 0 0 0
rg 0 0 0 0 0 6 0 1 5
rg 0 0 0 5 3 8 0 0 0
," Albert van der Horst's Python example"

CREATE grid20
rg 0 0 0 0 0 0 0 6 8
rg 9 0 0 0 0 0 0 0 2
rg 0 0 0 4 0 0 5 0 0
rg 0 4 1 0 0 0 0 0 0
rg 0 0 0 0 3 5 0 0 0
rg 0 5 0 0 0 0 0 0 0
rg 0 0 0 8 0 0 0 1 0
rg 3 0 0 0 0 0 7 0 0
rg 0 0 0 1 0 0 4 0 0
," Sudoku17.txt line 527"

CREATE grid21
rg 0 0 0 1 0 0 0 3 8
rg 2 0 0 0 0 5 0 0 0
rg 0 0 0 0 0 0 0 0 0
rg 0 5 0 0 0 0 4 0 0
rg 4 0 0 0 3 0 0 0 0
rg 0 0 0 7 0 0 0 0 6
rg 0 0 1 0 0 0 0 5 0
rg 0 0 0 0 6 0 2 0 0
rg 0 6 0 0 0 4 0 0 0
," Sudoku17.txt line 6361"

CREATE grid22
rg 8 0 0 0 0 0 0 0 0
rg 0 0 3 6 0 0 0 0 0
rg 0 7 0 0 9 0 2 0 0
rg 0 5 0 0 0 7 0 0 0
rg 0 0 0 0 4 5 7 0 0
rg 0 0 0 1 0 0 0 3 0
rg 0 0 1 0 0 0 0 6 8
rg 0 0 8 5 0 0 0 1 0
rg 0 9 0 0 0 0 4 0 0
," Arto Inkala, unsolvable to all but the sharpest minds"

CREATE grid23
rg 6 0 0 0 0 8 9 4 0
rg 9 0 0 0 0 6 1 0 0
rg 0 7 0 0 4 0 0 0 0

rg 2 0 0 6 1 0 0 0 0
rg 0 0 0 0 0 0 2 0 0
rg 0 8 9 0 0 2 0 0 0

rg 0 0 0 0 6 0 0 0 5
rg 0 0 0 0 0 0 0 3 0
rg 8 0 0 0 0 1 6 0 0
," David Filmer, rated above extreme"

CREATE grid24
rg 0 0 6 9 0 0 0 7 0
rg 0 0 0 0 1 0 0 0 2
rg 8 0 0 0 0 0 0 0 0

rg 0 2 0 0 0 0 0 0 4
rg 0 0 0 0 0 0 0 0 1
rg 0 0 5 0 0 6 0 0 0

rg 0 0 0 0 0 0 0 6 0
rg 0 0 0 0 0 2 0 5 0
rg 0 1 0 0 4 3 0 0 0
," W_a_x_man's challenge"

CREATE sudokugrid #81 ALLOT ( public, for Euler )

grid0 VALUE original

CREATE sudoku_row PRIVATE 9 CELLS ALLOT
CREATE sudoku_col PRIVATE 9 CELLS ALLOT
CREATE sudoku_box PRIVATE 9 CELLS ALLOT

DOC
(*
---------------------
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.
*)
ENDDOC

CREATE 'getrow #81 ALLOT
CREATE 'getcol #81 ALLOT
CREATE 'getbox #81 ALLOT

-- Grid Related

: getrow 9 / ; ( offset -- x )
: getcol 9 MOD ; ( offset -- y )
: getbox DUP getrow 3 / 3 * SWAP getcol 3 / + ; PRIVATE ( offset -- )

: 'getrow! #81 0 DO I getrow 'getrow I + C! LOOP ; 'getrow!
: 'getcol! #81 0 DO I getcol 'getcol I + C! LOOP ; 'getcol!
: 'getbox! #81 0 DO I getbox 'getbox I + C! LOOP ; 'getbox!

FORGET getrow

: getrow 'getrow + C@ ; PRIVATE ( offset -- x )
: getcol 'getcol + C@ ; PRIVATE ( offset -- y )
: getbox 'getbox + C@ ; PRIVATE ( offset -- n )

-- Puts and gets numbers from/to grid only
: setnumber sudokugrid + C! ; PRIVATE ( n position -- )
: getnumber sudokugrid + C@ ; PRIVATE ( position -- n )
: cleargrid sudokugrid #81 ERASE ; PRIVATE ( -- )

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

-- add n into bitmap
: addbits_row SWAP 2^x SWAP sudoku_row []CELL |! ; PRIVATE ( n index -- )
: addbits_col SWAP 2^x SWAP sudoku_col []CELL |! ; PRIVATE ( n index -- )
: addbits_box SWAP 2^x SWAP sudoku_box []CELL |! ; PRIVATE ( n index -- )

-- remove number n from bitmap
: removebits_row SWAP 2^x INVERT SWAP sudoku_row []CELL &! ; PRIVATE ( n index -- )
: removebits_col SWAP 2^x INVERT SWAP sudoku_col []CELL &! ; PRIVATE ( n index -- )
: removebits_box SWAP 2^x INVERT SWAP sudoku_box []CELL &! ; PRIVATE ( n index -- )

-- clears all bitmaps to 0
: clearbitmaps ( -- )
sudoku_row 9 CELLS ERASE
sudoku_col 9 CELLS ERASE
sudoku_box 9 CELLS ERASE ; PRIVATE

-- Adds number to grid and sets
: addnumber ( number ix -- )
2DUP setnumber
2DUP getrow addbits_row
2DUP getcol addbits_col
getbox addbits_box
1 +TO #spaces ; PRIVATE

-- Remove number from grid, and sets
: removenumber ( ix -- )
DUP getnumber swap
2DUP getrow removebits_row
2DUP getcol removebits_col
2DUP getbox removebits_box
NIP 0 SWAP setnumber
-1 +TO #spaces ; PRIVATE

-- gets bitmap at position
: getrow_bits getrow sudoku_row []CELL @ ; PRIVATE ( ix -- bitmap )
: getcol_bits getcol sudoku_col []CELL @ ; PRIVATE ( ix -- bitmap )
: getbox_bits getbox sudoku_box []CELL @ ; PRIVATE ( ix -- bitmap )

-- position -- composite bitmap (or'ed)
: getbits ( ix -- )
DUP getrow_bits
OVER getcol_bits
ROT getbox_bits OR OR ; PRIVATE

-- Try tests a number in a said position of grid
-- Returns true if it's possible, else false.
: try ( n ix -- bool ) getbits SWAP 2^x AND 0= ; PRIVATE

-- ---------------------------------------------
-- Parses Grid to fill sets.. Run before solver.

: parsegrid ( -- )
CLEAR #spaces
original sudokugrid #81 MOVE
[ #81 0 ] LOOP[ sudokugrid % + C@
DUP IF DUP % try IF % addnumber
ELSE DROP FALSE EXIT
ENDIF
ELSE DROP
ENDIF
] TRUE ; PRIVATE

-- Morespaces? manually checks for spaces ...
: morespaces? #81 #spaces - ; PRIVATE ( -- n )

: findnextmove ( -- n ) \ n = index next item, if -1 finished.
-1 10 \ index prev_possibilities --
[ #81 0 ] LOOP[
% sudokugrid + C@ 0= IF 9 % getbits countbits -
2DUP > IF NIP NIP % SWAP
ELSE DROP
ENDIF
ENDIF ]
DROP ; PRIVATE

-- 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.
-- Unrolling this word makes it slower.
: solver ( -- bool )
findnextmove dup 0< IF DROP morespaces? 0= EXIT THEN
#10 1 DO I OVER try
IF I OVER addnumber
recurse IF DROP TRUE UNLOOP EXIT
ELSE DUP removenumber
ENDIF
ENDIF
LOOP DROP FALSE ; PRIVATE

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

-- ---------------------
-- Display Grid
-- ---------------------
: .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
ENDIF
ENDIF
ELSE ." | "
ENDIF
ENDIF
DROP
LOOP DROP ;

: solveit ( -- )
CR CR ." ** " original #81 + COUNT -TRAILING TYPE ." **"
CR TIMER-RESET
startsolving MS? SWAP
IF ." Solution found in " n.ELAPSED CR .sudokugrid
ELSE ." No solution found " DROP
ENDIF ;

: speedit ( -- )
PRECISION >S 3 SET-PRECISION
CR TIMER-RESET
#do 0 DO startsolving DROP LOOP
MS? S>F #do S>F F/ FDUP F>S TO longtime F. ." milliseconds ("
original #81 + COUNT -TRAILING TYPE &) EMIT
S> SET-PRECISION ;

: (speedit) ( -- ) TIMER-RESET startsolving DROP MS? TO longtime ;

: speedthem ( -- )
grid0 TO original speedit
grid1 TO original speedit
grid2 TO original speedit
grid3 TO original speedit
grid4 TO original speedit
grid5 TO original speedit
grid6 TO original speedit
grid7 TO original speedit
grid8 TO original speedit
grid9 TO original speedit
grid10 TO original speedit
grid11 TO original speedit
grid12 TO original speedit
grid13 TO original speedit
grid14 TO original speedit
grid15 TO original speedit
grid16 TO original speedit
grid17 TO original speedit
grid19 TO original speedit
grid20 TO original #do 1 TO #do speedit TO #do
grid21 TO original #do 1 TO #do speedit TO #do
grid22 TO original speedit
grid23 TO original speedit
grid24 TO original #do 1 TO #do speedit TO #do ;

: godoit ( -- )
clearbitmaps
parsegrid IF CR ." Grid in source valid. "
ELSE CR ." Warning: grid in source invalid. "
ENDIF
.sudokugrid ;

-- the 17-number-Sudoku file
CREATE temp PRIVATE #128 CHARS ALLOT

: READS ( u -- )
0 0 LOCALS| old-do handle su |
S" sudoku17.txt" R/W BIN OPEN-FILE ?FILE TO handle
su 0 ?DO
PAD #100 handle READ-LINE ?FILE NIP
0= IF CR ." ==EOF==" UNLOOP EXIT
ENDIF
LOOP
temp #81 handle READ-FILE ?FILE DROP
handle CLOSE-FILE ?FILE
#do TO old-do #10 TO #do
temp #81 BOUNDS DO I C@ '0' - I C! LOOP
S" sudoku17 -- #" su (0DEC.R) $+ temp #81 + PACK DROP
temp TO original speedit
old-do TO #do ;

: READN ( start su -- )
0 0 0 0 LOCALS| ilongest ilongtime old-do handle su start |
S" sudoku17.txt" R/W BIN OPEN-FILE ?FILE TO handle
start 0 ?DO
PAD #100 handle READ-LINE ?FILE NIP
0= IF CR ." ==EOF==" UNLOOP EXIT ENDIF
LOOP
#do TO old-do #10 TO #do
su start
?DO
temp #100 handle READ-LINE ?FILE NIP
0= IF CR ." ==EOF==" LEAVE ENDIF
temp #81 BOUNDS DO I C@ '0' - I C! LOOP
S" sudoku17 -- #" I (0DEC.R) $+ temp #81 + PACK DROP
temp TO original speedit
longtime ilongtime U> IF longtime TO ilongtime I TO ilongest ENDIF
LOOP
old-do TO #do
handle CLOSE-FILE ?FILE
CR ." Most difficult Sudoku at line " ilongest DEC. ." took " ilongtime DEC. ." milliseconds." ;

: NGO ( start su -- )
0 0 0 0 LOCALS| sum ilongest ilongtime handle |
S" all_17_clue_sudokus.txt" R/W BIN OPEN-FILE ?FILE TO handle
#49152 0 ?DO
temp #100 handle READ-LINE ?FILE NIP
0= IF CR ." ==EOF==" LEAVE ENDIF
temp #81 BOUNDS DO I C@ '0' - I C! LOOP
S" all_17_clue_sudokus -- #" I (0DEC.R) $+ temp #81 + PACK DROP
temp TO original (speedit)
longtime +TO sum
longtime ilongtime U> IF longtime TO ilongtime I TO ilongest ENDIF
LOOP
handle CLOSE-FILE ?FILE
CR ." Most difficult Sudoku at line " ilongest DEC. ." took " ilongtime DEC. ." milliseconds."
CR ." Total time: " sum U>D #1000 UM/MOD 0DEC.R '.' EMIT . ." seconds." ;

-- Most difficult Sudoku at line 6361 took 1661 milliseconds. ok

:ABOUT CR ." ========================== Sudoku ==============================="
CR ." gridX TO original -- choose grid X, where X = {0,1,..24}"
CR ." godoit -- print, preliminary checks"
CR ." solveit -- solve current grid"
CR ." speedit -- test how fast current grid can be solved"
CR ." speedthem -- test speed of all grids"
CR ." ( +n) reads -- read a 17-number sudoku from sudoku17.txt and time it (6361)"
CR ." ( start +n) readn -- read 17-number sudoku's between start and n (1 6362)"
CR ." NGO -- read 49152 17-number sudoku's (GO contest, 6 minutes)" ;

NESTING @ 1 = [IF] godoit
.ABOUT -sudoku CR
[THEN]

DEPRIVE

(* End of Source *)