This is an incomplete, untested, and, un-commented, and undocumented
sudoku solver in forth. Not only that but it's actually amusing if
you read between the lines. Of course, that my cause you to experience
excruciating headaches and possibly hallucinations .......
Remember if you use this code and you or your computer or your
family or friends begin to experience " black outs " it is not the direct
responsibility of the author, his computer, his family or his friends.
and thanks for the fish ....
9 constant width
81 constant size
42 constant empty
variable board size allot
board size empty fill
( read file into buffer )
variable buff 1000 allot
0 Value fh
s" sud_puzzle1" r/o open-file throw to fh
buff 1000 fh read-file throw drop
fh close-file throw
: buff-to-board
size 0 ?do
buff i + @ board i + ! loop ;
variable line-no
: board-fetch
board width line-no @ * + ;
: print-line
line-no !
width 0 ?do
board-fetch i + c@ emit loop ;
: print-board
cr
width 0 ?do
i print-line cr loop ;
: test-aster 42 = if s" eq " type else s" not eq " type then ;
: check-sq-1 col-no @ 3 < and line-no @ 3 < if 1 else 0 then ;
: check-sq-2 col-no @ 3 < and line-no @ 3 6 within if 2 else 0 then ;
: check-sq-3 col-no @ 3 < and line-no @ 6 9 within if 3 else 0 then ;
: check-sq-4 col-no @ 3 6 within and line-no @ 3 < if 4 else 0 then ;
: check-sq-5 col-no @ 3 6 within and line-no @ 3 6 within if 5 else 0 then ;
: check-sq-6 col-no @ 3 6 within and line-no @ 6 9 within if 6 else 0 then ;
: check-sq-7 col-no @ 6 9 within and line-no @ 3 < if 7 else 0 then ;
: check-sq-8 col-no @ 6 9 within and line-no @ 3 6 within if 8 else 0 then ;
: check-sq-9 col-no @ 6 9 within and line-no @ 6 9 within if 9 else 0 then ;
variable terr
variable blkn
: check-terr1 col-no @ < 3 if 1 terr ! then ;
: check-terr2 col-no @ 3 6 within if 2 terr ! then ;
: check-terr3 col-no @ 6 9 within if 3 terr ! then ;
: check-blkn1 line-no @ < 3 if 1 blkn ! then ;
: check-blkn2 line-no @ 3 6 within if 2 blkn ! then ;
: check-blkn3 line-no @ 6 9 within if 3 blkn ! then ;
: check-sq-1 terr @ 1 = if blkn @ 1 = if 1 else 0 then else 0 then ;
: check-sq-2 terr @ 1 = if blkn @ 2 = if 2 else 0 then else 0 then ;
: check-sq-3 terr @ 1 = if blkn @ 3 = if 3 else 0 then else 0 then ;
: check-sq-4 terr @ 2 = if blkn @ 1 = if 4 else 0 then else 0 then ;
: check-sq-5 terr @ 2 = if blkn @ 2 = if 5 else 0 then else 0 then ;
: check-sq-6 terr @ 2 = if blkn @ 3 = if 6 else 0 then else 0 then ;
: check-sq-7 terr @ 3 = if blkn @ 1 = if 7 else 0 then else 0 then ;
: check-sq-8 terr @ 3 = if blkn @ 2 = if 8 else 0 then else 0 then ;
: check-sq-9 terr @ 3 = if blkn @ 3 = if 9 else 0 then else 0 then ;
: check-sq col-no ! line-no !
check-terr1
check-terr2
check-terr3
check-blkn1
check-blkn2
check-blkn3
check-sq-1
check-sq-2
check-sq-3
check-sq-4
check-sq-5
check-sq-6
check-sq-7
check-sq-8
check-sq-9
+ + + + + + + + ;
variable v1
variable v2
variable v3
variable v4
variable v5
variable v6
variable v7
variable v8
variable v9
variable vp1
variable vp2
variable vp3
variable vp4
variable vp5
variable vp6
variable vp7
variable vp8
variable vp9
: @1 v1 @ ;
: !1 v1 ! ;
: @2 v2 @ ;
: !2 v2 ! ;
: @3 v3 @ ;
: !3 v3 ! ;
: @4 v4 @ ;
: !4 v4 ! ;
: @5 v1 @ ;
: !5 v1 ! ;
: @6 v6 @ ;
: !6 v6 ! ;
: @7 v7 @ ;
: !7 v7 ! ;
: @8 v8 @ ;
: !8 v8 ! ;
: @9 v9 @ ;
: !9 v9 ! ;
: @p1 vp1 @ ;
: !p1 vp1 ! ;
: @p2 vp2 @ ;
: !p2 vp2 ! ;
: @p3 vp3 @ ;
: !p3 vp3 ! ;
: @p4 vp4 @ ;
: !p4 vp4 ! ;
: @p5 vp1 @ ;
: !p5 vp1 ! ;
: @p6 vp6 @ ;
: !p6 vp6 ! ;
: @p7 vp7 @ ;
: !p7 vp7 ! ;
: @p8 vp8 @ ;
: !p8 vp8 ! ;
: @p9 vp9 @ ;
: !p9 vp9 ! ;
variable nextval
variable sv-nextval
variable nextavailable
variable inpv
variable dupr
: nextval@ nextval @ ;
: nextval! nextval ! ;
: sv-nextval@ sv-nextval @ ;
: sv-nextval! sv-nextval ! ;
: nv! nextval@ 1 = if !1 else nextval@
2 = if !2 else nextval@
3 = if !3 else nextval@
4 = if !4 else nextval@
5 = if !5 else nextval@
6 = if !6 else nextval@
7 = if !7 else nextval@
8 = if !8 else nextval@
9 = if !9
then then then then then then then then then ;
: nv@ nextval@ 1 = if @1 else nextval@
2 = if @2 else nextval@
3 = if @3 else nextval@
4 = if @4 else nextval@
5 = if @5 else nextval@
6 = if @6 else nextval@
7 = if @7 else nextval@
8 = if @8 else nextval@
9 = if @9
then then then then then then then then then ;
: nvp! nextpval@ 1 = if !p1 else nextpval@
2 = if !p2 else nextpval@
3 = if !p3 else nextpval@
4 = if !p4 else nextpval@
5 = if !p5 else nextpval@
6 = if !p6 else nextpval@
7 = if !p7 else nextpval@
8 = if !p8 else nextpval@
9 = if !p9
then then then then then then then then then ;
: nvp@ nextpval@ 1 = if @p1 else nextpval@
2 = if @p2 else nextpval@
3 = if @p3 else nextpval@
4 = if @p4 else nextpval@
5 = if @p5 else nextpval@
6 = if @p6 else nextpval@
7 = if @p7 else nextpval@
8 = if @p8 else nextpval@
9 = if @p9
then then then then then then then then then ;
: reset-nextval sv-nextval@ nextval! ;
: set-sv nextval@ sv-nextval! ;
: check-unique inpv ! 0 dupr ! set-sv
10 1 ?do i nextval! nv@ inpv @ = if 1 dupr ! then loop
reset-nextval dupr @ ;
: store-input check-unique 0 = if inpv @ nv! nextval@ 1 + nextval! then ;
: load-from-row
line-no !
width 0 ?do
board-fetch i + c@ dup current-val ! 42 <> if current-val @ store-input then loop ;
variable offset
: column-calc line-no ! board line-no @ width * + ;
: column-calc2 board line-no @ width * + ;
: print-column cr offset ! board offset @ + c@ emit cr
width 1 ?do i column-calc offset @ + c@ emit cr loop ;
: load-from-column offset ! board offset @ + c@ dup current-val ! 42 <> if store-input then
9 1 ?do i column-calc offset @ + c@ dup current-val ! 42 <> if store-input then loop ;
: sq1-print 3 0 ?do i line-no ! 3 0 ?do i column-calc2 + c@ emit loop loop ;
: sq2-print 3 offset ! 3 0 ?do i line-no ! 3 0 ?do i column-calc2 + offset @ + c@ emit loop loop ;
: sq3-print 6 offset ! 3 0 ?do i line-no ! 3 0 ?do i column-calc2 + offset @ + c@ emit loop loop ;
: sq4-print 6 3 ?do i line-no ! 3 0 ?do i column-calc2 + c@ emit loop loop ;
: sq5-print 3 offset ! 6 3 ?do i line-no ! 3 0 ?do i column-calc2 + offset @ + c@ emit loop loop ;
: sq6-print 6 offset ! 6 3 ?do i line-no ! 3 0 ?do i column-calc2 + offset @ + c@ emit loop loop ;
: sq7-print 9 6 ?do i line-no ! 3 0 ?do i column-calc2 + c@ emit loop loop ;
: sq8-print 3 offset ! 9 6 ?do i line-no ! 3 0 ?do i column-calc2 + offset @ + c@ emit loop loop ;
: sq9-print 6 offset ! 9 6 ?do i line-no ! 3 0 ?do i column-calc2 + offset @ + c@ emit loop loop ;
: sq1-load 3 0 ?do i line-no ! 3 0 ?do i column-calc2 + c@ 42 <> if store-input then loop loop ;
: sq2-load 3 offset ! 3 0 ?do i line-no ! 3 0 ?do i column-calc2 + offset @ + c@ 42 <> if store-input then loop loop ;
: sq3-load 6 offset ! 3 0 ?do i line-no ! 3 0 ?do i column-calc2 + offset @ + c@ 42 <> if store-input then loop loop ;
: sq4-load 6 3 ?do i line-no ! 3 0 ?do i column-calc2 + c@ 42 <> if store-input then loop loop ;
: sq5-load 3 offset ! 6 3 ?do i line-no ! 3 0 ?do i column-calc2 + offset @ + c@ 42 <> if store-input then loop loop ;
: sq6-load 6 offset ! 6 3 ?do i line-no ! 3 0 ?do i column-calc2 + offset @ + c@ 42 <> if store-input then loop loop ;
: sq7-load 9 6 ?do i line-no ! 3 0 ?do i column-calc2 + c@ 42 <> if store-input then loop loop ;
: sq8-load 3 offset ! 9 6 ?do i line-no ! 3 0 ?do i column-calc2 + offset @ + c@ 42 <> if store-input then loop loop ;
: sq9-load 6 offset ! 9 6 ?do i line-no ! 3 0 ?do i column-calc2 + offset @ + c@ 42 <> if store-input then loop loop ;
variable sq-no
: square-load sq-no ! sq-no @ 1 = if sq1-load else
sq-no @ 2 = if sq2-load else
sq-no @ 3 = if sq3-load else
sq-no @ 4 = if sq4-load else
sq-no @ 5 = if sq5-load else
sq-no @ 6 = if sq6-load else
sq-no @ 7 = if sq7-load else
sq-no @ 8 = if sq8-load else
sq-no @ 9 = if sq9-load then
then then then then then then then then ;
: fill-constraints check-sq square-load col-no @ load-from-column line-no @ load-from-row ;
variable fnd
variable nextpval
: check-possible nextpval @ 1 - ;
: store-possible nvp! nextpval @ 1 + nextpval ! ;
: find-possible 0 fnd ! 10 1 ?do i dup check-val ! nextval! nv@ check-val @ = if 1 fnd ! then loop fnd @ 0 = if store-possible then ;
: store-cell board line-no + col-no 9 * + nvp@ ! ;
: load-cell check-possible 1 = if store-cell then ;
