Sudoku.fs

#! /usr/bin/env gforth



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

0 constant _

defer |

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

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

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

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

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

: >board ( 81*fields board -- )
	dup 80 + DO
		i c!
	-1 +LOOP ;

: row>board ( row board+row-index -- )
	dup 8 + DO
		10 /mod swap i c!
	-1 +LOOP drop ;

: rows>board ( 9*row board -- )
	dup 72 + DO
		i row>board
	-9 +LOOP ;

: delete ( board -- )
	81 erase ;



( ============================================================================ )
( = 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 ( board -- board+3 )
	3 0 DO
		space dup c@ .digit 1+
	LOOP .v-bar ;
	
: .row ( board -- board+9 )
	.v-bar 3 0 DO
		.1/3row
	LOOP ;

: .3rows ( board -- board+27 )
	3 0 DO
		.row cr
	LOOP ;

: .board ( board -- )
	.h-bar 3 0 DO
		.3rows .h-bar
	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 81 0 DO
		2dup i + c@ = IF
			2drop true
			UNLOOP EXIT
		THEN
	9 +LOOP 2drop false ;

: field?
	2dup i + c@ = IF
		2drop true
		rdrop UNLOOP EXIT
	THEN ;

: 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
	ELSE
		2dup + c@ IF
			1+ RECURSE
		ELSE		
			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
		THEN
	THEN ;

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


: (ok) ."   ok" ; latestxt is bootmessage