Sudoku.fs

#! /usr/bin/env gforth



( ============================================================================ )
( = Sudoku input															 = )
( ============================================================================ )

0 constant _

defer |

: <+---------+---------+---------+> ;
: [+---------+---------+---------+] ;

:  |> ( char1 char2 char3 -- )
	rot c, swap c, c, ;

:  |] ( char1 char2 char3 -- )
	>r >r over c! 1+ r> over c! 1+ r> over c! 1+ ;

: <|  ( -- )
	['] |> is | ;

: [|  ( -- )
	['] |] is | ;



( ============================================================================ )
( = Create sudoku															 = )
( ============================================================================ )

create board
	<+---------+---------+---------+>
	<| 2  _  _ | 6	7  _ | _  _  _ |>
	<| _  _  6 | _	_  _ | 2  _  1 |>
	<| 4  _  _ | _	_  _ | 8  _  _ |>
	<+---------+---------+---------+>
	<| 5  _  _ | _	_  9 | 3  _  _ |>
	<| _  3  _ | _	_  _ | _  5  _ |>
	<| _  _  2 | 8	_  _ | _  _  7 |>
	<+---------+---------+---------+>
	<| _  _  1 | _	_  _ | _  _  4 |>
	<| 7  _  8 | _	_  _ | 6  _  _ |>
	<| _  _  _ | _	5  3 | _  _  8 |>
	<+---------+---------+---------+>



( ============================================================================ )
( = Show sudoku																 = )
( ============================================================================ )

: digit>char ( digit -- char )
	[char] 0 + ;

char | constant v-bar
: .v-bar ( -- )
	v-bar emit ;

s" +---------+---------+---------+" 2constant h-bar
: .h-bar ( -- )
	h-bar type cr ;

: .digit>0 ( char -- )
	dup 9 u> IF
		drop [char] ? emit
	ELSE
		digit>char emit
	THEN space ;

: .digit ( char -- )
	dup 0= IF
		drop space space
	ELSE
		.digit>0
	THEN ;

: .1/3row ( addr -- )
	3 0 DO
		space dup c@ .digit
		1+
	LOOP drop .v-bar ;
	
: .row ( addr -- )
	.v-bar 3 0 DO
		dup .1/3row
		3 +
	LOOP drop ;

: .3rows ( addr -- )
	3 0 DO
		dup .row cr
		9 +
	LOOP drop ;

: .board ( addr -- )
	.h-bar 3 0 DO
		dup .3rows .h-bar
		27 +
	LOOP drop ;



( ============================================================================ )
( = Now solve it.															 = )
( ============================================================================ )

: >row    ( index -- row-index )
	9 / 9 * ;

: >column ( index -- column-index )
	9 mod ;

: >box    ( index -- box-index )
	27 /mod 27 * swap 9 mod 3 / 3 * + ;

: row?    ( board+index digit -- found? )
	swap 9 0 DO
		2dup i + c@ = IF
			2drop true
			UNLOOP EXIT
		THEN
	LOOP 2drop false ;

: column? ( board+index digit -- found? )
	swap 9 0 DO
		2dup 9 i * + c@ = IF
			2drop true
			UNLOOP EXIT
		THEN
	LOOP 2drop false ;

: box?    ( board+index digit -- found? )
	swap 03 00 DO 2dup i + c@ = IF 2drop true UNLOOP EXIT THEN LOOP
	     12 09 DO 2dup i + c@ = IF 2drop true UNLOOP EXIT THEN LOOP
	     21 18 DO 2dup i + c@ = IF 2drop true UNLOOP EXIT THEN LOOP
	2drop false ;

: fits? ( board index digit -- unused? )
	>r 2dup >row    + r@ row?    IF 2drop rdrop false ELSE
	   2dup >column + r@ column? IF 2drop rdrop false ELSE
	        >box    + r> box?    IF             false ELSE
	true THEN THEN THEN ;

: guess ( board index -- solved? )
	dup 81 = IF
		2drop true EXIT
	THEN
	
	2dup + c@ IF
		1+ RECURSE EXIT
	THEN
	
	10 1 DO
		2dup i fits? IF
			2dup + i swap c!
			2dup 1+ RECURSE IF
				2drop true
				UNLOOP EXIT
			THEN
		THEN
	LOOP
	+ 0 swap c!
	false ;

: solve		( board -- )
	." Unsolved:" cr
	board .board cr cr
	0 guess IF
		." Solved:" cr
		board .board
	ELSE
		." No solution found."
	THEN cr ;

board solve