www.jupiter-ace.co.uk

Previous Page > Listings Index > Sudoko


Sudoku
by
Ricardo Fernandes Lopes
You can download the code as a WAV, ACE and TAP files from the archive
( SUDOKU version 1.0                         )
( A game for the Jupiter Ace computer        )
( copyright (c) 2007 by Ricardo F. Lopes     )
( under the GPL (General Public License) v.2 )

( ==================== )
(  Graphic Characters  )
( ==================== )

CREATE GRAPH 248 ALLOT  ( Font buffer )
GRAPH 248 BLOAD sdkfont ( Load font file to buffer )

( Install font: ASCII 1 to 31 )
: GR  248 0 DO GRAPH I + C@ 11272 I + C! LOOP ;

( ================= )
(  Draw Game Board  )
( ================= )

( type strings in GRAPHIC mode )
: L0  CR ." O > > O > > O > > O" ; ( cell lines )
: L1  CR ." 6=<=<=5=<=<=5=<=<=8" ; ( thin line separator )
: L2  CR ." 1N9N9N0N9N9N0N9N9N2" ; ( fat line separator )
: FRAME ( draw board frame )
 CLS
 ." JN:N:N3N:N:N3N:N:NK"   ( top border  )
 L0 L1 L0 L1 L0 L2         ( lines 1 2 3 )
 L0 L1 L0 L1 L0 L2         ( lines 4 5 6 )
 L0 L1 L0 L1 L0 CR         ( lines 7 8 9 )
 ." LN;N;N4N;N;N4N;N;N?" ; ( bottom border )

: SCREEN
 FRAME
  0 20 AT ." _SUDOKU_1.0_"
  2 20 AT ." Page: 0"
  4 21 AT ." I"
  5 20 AT ." JKL Move"
  7 20 AT ." P N Pg sel"
 13 21 AT ." C  Clear"
 15 21 AT ." E  Edit On"
 17 21 AT ." Q  Quit"
 21 0 AT
 ."    c 2007 by Ricardo F. Lopes   "
 ."  GNU General Public License v.2" ;

( =================== )
(  READ THE KEYBOARD  )
( =================== )

16 BASE C!
CREATE >UPPER ( c -- C : convert a character to uppercase )
 DF C,             ( RST  18h   ; E = char to convert     )
 7B C,             ( LD   A,E   ; A = char to convert     )
 CD C, 07 C, 08 C, ( CALL 0807h ; to-upper ROM routine    )
 5F C,             ( LD   E,A   ; E = converted char      )
 D7 C,             ( RST  10h   ; Push char to Data Stack )
 FD C, E9 C,       ( JP   [IY]  ; end                     )
>UPPER DUP 2- !    ( make TOUPPER an executable word )
DECIMAL

: KEY ( -- c : wait for a keypress )
 BEGIN INKEY 0= UNTIL
 BEGIN INKEY ?DUP UNTIL ;

( =============== )
(  SCREEN CURSOR  )
( =============== )

: CURSOR ( i -- adr : Get screen cursor address )
 9 /MOD ( col lin )
 32 * + 2 * 9249 + ;
: ON  ( adr -- )  DUP C@ 128 OR SWAP C! ;   ( Invert video )
: OFF ( adr -- )  DUP C@ 127 AND SWAP C! ;  ( Normal video )

( =================== )
(  PUZZLE COLLECTION  )
( =================== )
20 CONSTANT #PG            ( Number of puzzles )
CREATE PGS #PG 81 * ALLOT  ( Sudoku collection )
0 VARIABLE PG              ( Current page )
: PG>  ( pg -- adr )  81 * PGS + ;  ( Get page address )
: IDX> ( i -- adr )   PG @ PG> + ;  ( Get cell address )
: GET ( i -- c )  IDX> C@ ;         ( Get cell content )
: SET ( c i -- : Set cell content )
 OVER OVER IDX> C! ( set cell content )
 CURSOR C! ;       ( update screen )

: LOADPG  ( pg -- : Load puzzle to screen )
 0 MAX #PG 1- MIN ( Limit page range )
 DUP PG !         ( Set as current page )
 DUP 2 26 AT .    ( Show page number )
 PG>              ( Get page address )
 81 0             ( Copy puzzle to screen )
 DO
  DUP C@       ( Get value )
  I CURSOR C!  ( Place it into the screen )
  1+           ( Point to next value )
 LOOP
 DROP ;

( Change current page )
: PG+ ( n -- )  PG @ + LOADPG ;

( ====================== )
(  CHECK ALLOWED VALUES  )
( ====================== )

CREATE HINTS 10 ALLOT ( List of allowed values )
: HINT@ ( c -- f )  HINTS + C@ ;
: HINT! ( f c -- )  HINTS + C! ;
: HINT0 ( Initialize list allowing all values )
 10 1
 DO
  I I HINT!
 LOOP
 32 0 HINT! ; ( value=0 is always allowed )

: RMV ( c -- c : Remove c from the list of allowed values)
 0 OVER GET 15 AND ( Mask ASCII 0 out )
 ?DUP              ( Not zero? )
 IF
  HINT!
 ELSE
  DROP
 THEN ;

: LSCN ( lin -- : Scan line )
 9 * ( index )
 9 0
 DO
  RMV 1+
 LOOP
 DROP ;

: CSCN ( col -- : Scan column )
 9 0
 DO
  RMV 9 +
 LOOP
 DROP ;

( Lookup table for square index )
CREATE BC  0 C, 0 C, 0 C,  3 C,  3 C,  3 C,  6 C,  6 C,  6 C,
CREATE BL  0 C, 0 C, 0 C, 27 C, 27 C, 27 C, 54 C, 54 C, 54 C,
: SSCN ( col lin -- : Scan square )
 BL + C@
 SWAP BC + C@ + ( index )
 3 0   ( 3 lines )
 DO
  3 0  ( 3 columns )
  DO
   RMV 1+
  LOOP
  6 +  ( next line )
 LOOP
 DROP ;

: SCAN ( i -- : Scan line, column and square, removing founded values from list )
 9 /MOD ( col lin )
 OVER CCHK ( Check column   )
 DUP  LCHK ( Check line )
 BCHK ;    ( Check square )

: .HINT ( i -- : Show allowed values at cell i )
 HINT0 SCAN
 20 1 AT
 10 1
 DO
  I HINT@ ?DUP
  IF
   .
  ELSE
   2 SPACES
  THEN
 LOOP ;

( ============= )
(  PUZZLE EDIT  )
( ============= )
( ASCII  0 to  9 = locked cells: can be changed only in edit mode )
( ASCII 48 to 57 = unlocked cells: can be changed at will )

ASCII 0 VARIABLE NED ( True when not in Edit Mode )
: XED ( Toogle Edit Mode On/Off )
 15 29 AT
 NED @
 IF
   ." Off"
  19 1 AT ." ____EDIT_MODE____"
  0
 ELSE
  ." On "
  19 1 AT 17 SPACES
  ASCII 0
 THEN
 NED ! ;

: BZZ  300 50 BEEP ;  ( Not-Ok tone )
: BIP  30 DUP BEEP ;  ( Ok tone )

: WRITE ( i c -- i : Change value, checking if allowed )
 DUP HINT@ ( Is an allowed value?)
 IF
  NED @    ( Is not editing?)
  IF
   OVER GET
   DUP 0> SWAP   ( Is cell not empty?)
   ASCII 0 < AND ( Is cell locked? )
   IF            ( Locked cell: Discard value)
    DROP BZZ
   ELSE          ( Unlocked cell: Ok to change)
    DUP IF ASCII 0 + THEN ( if not clearing, set as user input )
    OVER SET BIP
   THEN
  ELSE           ( Edit mode: Ok to change)
   OVER SET BIP
  THEN
 ELSE            ( Not an allowed value: Discard it )
  DROP BZZ
 THEN ;

: CLR ( Clear all inputs )
 81 0
 DO
  I 0 WRITE DROP
 LOOP ;

( =========== )
(  Game Play  )
( =========== )

( Changing the current index position )
-9 CONSTANT UP
-1 CONSTANT LF
 1 CONSTANT RG
 9 CONSTANT DN
: GO ( i dir -- i )  + 0 MAX 80 MIN ;

: PLAY ( key i -- key i : Interpret input and take action)
 OVER ASCII I = IF UP GO THEN
 OVER ASCII J = IF LF GO THEN
 OVER ASCII K = IF DN GO THEN
 OVER ASCII L = IF RG GO THEN
 OVER ASCII N = IF RG PG+ THEN
 OVER ASCII P = IF LF PG+ THEN
 OVER ASCII C = IF CLR THEN
 OVER ASCII E = IF XED THEN
 OVER ASCII 0 -
 DUP -1 > OVER 10 < AND
 IF WRITE ELSE DROP THEN ;

: SUDOKU ( Main routine, start the game with this word )
 INVIS FAST
 GR SCREEN         ( Draw screen              )
 ASCII 0 NED !     ( Not in edit mode         )
 0 LOADPG          ( Load first puzzle page   )
 40                ( Set initial cursor index )
 BEGIN
  DUP .HINT        ( Scan for allowed values )
  DUP CURSOR ON
  KEY >UPPER SWAP  ( Get user input )
  DUP CURSOR OFF
  PLAY
  SWAP ASCII Q =   ( Quit? )
 UNTIL
 DROP VIS SLOW ;