small constants, keyboard input, interactive minesweeper

asm.jrt

@@ -205,7 +205,7 @@ var ignoreimm
 : diffaddr ( opsize -- diff ) oparg-val @ swap target + - ;
 : oparg-nearaddr? ( -- f ) oparg-mem? oparg-base @ -1 = and ;
 : >short-jmp* ( op -- ) oparg-nearaddr? if
-    2 diffaddr dup dbg" jumping by" byteval? oparg-mempatch? or
+    2 diffaddr dup byteval? oparg-mempatch? or
     if swap >t ' patch-r8 patchpoint >t 2ret then drop
   then drop ;
 : >near-reljmp* ( op -- ) oparg-nearaddr? if

coredefs.jrt

@@ -8,16 +8,6 @@ dbg" core"
   MOV BX AX
   JMP @[ BX] ;
 
-L: $$CONST
-  INC BX INC BX
-  PUSH @[ BX]
-  NEXT
-
-: CONST DEF [ L@ $$CONST lit ] w>t w>t ;
-
-L@ $$CONST CONST $DOCONST
-0 CONST 0 1 CONST 1
-
 L: $$VAR
   INC BX INC BX
   PUSH BX
@@ -29,7 +19,33 @@ L: $$VAR
 ( "codepointer words" that evaluate to a pointer to the assembly -
   useful to define things like $DOCOLON. )
 : :CP ARRAY ;
+
+:CP $DOCONST
+  INC BX INC BX
+  PUSH @[ BX]
+  NEXT
+
+:CP $DOBCONST
+  INC BX INC BX
+  MOV AL @[ BX]
+  CBW
+  PUSH AX
+  NEXT
+
+:CP $DOUBCONST
+  INC BX INC BX
+  XOR AX AX
+  MOV AL @[ BX]
+  PUSH AX
+  NEXT
+
+: CONST DEF 
+  dup byteval? if [ t& $DOBCONST lit ] w>t >t return then
+  dup 0 >= over 255 <= and if [ t& $DOUBCONST lit ] w>t >t return then
+  [ t& $DOCONST lit ] w>t w>t ;
+
 L@ $$VAR CONST $DOVAR
+0 CONST 0 1 CONST 1
 
 :CP $DOCOLON
   MOV @[ BP] SI
@@ -71,7 +87,6 @@ L@ $$VAR CONST $DOVAR
   MOV SI AX
   NEXT
 
-
 :ASM BZ_
   POP CX
   JCXZ 0 @>
@@ -126,11 +141,6 @@ DEF GOTO_ L@ GOTO_IMPL w>t
   ( this costs 1 extra byte but should save 20 clock cycles )
   MOV BX SP
   PUSH @[ 2 @+ SS: BX]
-(  POP AX
-  POP BX
-  PUSH BX
-  PUSH AX
-  PUSH BX )
   NEXT
 
 :ASM <rot

keys.jrt

@@ -0,0 +1,38 @@
+:asm read-shiftflags
+  MOV AH 0x12 #
+  INT 0x16 #
+  PUSH AX
+  NEXT
+
+:asm wait-key
+  XOR AX AX
+  INT 0x16 #
+  PUSH AX
+  NEXT
+
+: key>scan 8 >> ;
+: key>ch 0xff & ;
+: scanup 0x80 | ;
+
+0x4b const %left
+0x4d const %right
+0x48 const %up
+0x50 const %down
+0x1c const %enter
+0x01 const %esc
+0x1d const %lctrl
+0x2a const %lshift
+0x36 const %rshift
+0x38 const %lalt
+0x39 const %space
+0x3a const %capslock
+0x3b const %f1
+: %f %f1 + ;
+0x47 const %home
+0x49 const %pgup
+0x4f const %end
+0x51 const %pgdn
+0x52 const %ins
+0x53 const %del
+0x0e const %bs
+

logic.jrt

@@ -39,7 +39,7 @@ dbg" math"
 dbg" comparisons"
 L: TRUE 0xffff w>t
 L: FALSE 0 w>t
-L: RETTRUE target .hex
+L: RETTRUE
   PUSH TRUE
   NEXT
 L: RETFALSE
@@ -49,7 +49,6 @@ L: RETFALSE
 :ASM not
   POP AX
   OR AX AX
-  L@ RETTRUE .hex
   JZ RETTRUE
   JMP RETFALSE
 

mines.jrt

@@ -1,6 +1,12 @@
 import text.jrt
+import keys.jrt
 import random.jrt
 
+: !+ ( v p -- ) dup @ <rot + swap ! ;
+: b!+ ( v p -- ) dup b@ <rot + swap b! ;
+: b!| ( f p -- ) dup b@ <rot | swap b! ;
+: b!^ ( f p -- ) dup b@ <rot ^ swap b! ;
+
 30 const maxw 16 const maxh
 array board maxw maxh * allot
 
@@ -46,8 +52,7 @@ array board maxw maxh * allot
      swap 1+ swap 1+ <r do-at ;
 
 0 var, curr-mine-count
-: count-mine-at ( x y -- ) 
+: count-mine-at ( x y -- ) mine-at? if 1 curr-mine-count !+ then ;
-  mine-at? if curr-mine-count @ 1+ curr-mine-count ! then ;
 : analyze-pos ( x y -- n )
   0 curr-mine-count ! ' count-mine-at do-at-neighbours curr-mine-count @ ;
 : analyze-board
@@ -77,14 +82,17 @@ array countcolors white b, lblue b, lgreen b, red b, blue b,
 : pos>screen ( x y -- x y )
   swap pagew boardw @ - 2/ +
   swap pageh boardh @ - 2/ + ;
-
+: boardx ( -- x ) pagew boardw @ 2* 1+ - 2/ ;
-: boardx! ( -- ) pagew boardw @ 2* 1+ - 2/ textx! ;
+: boardy ( -- y ) pageh boardh @ 2* 1+ - 2/ ;
-: boardy! ( -- ) pageh boardh @ 2* 1+ - 2/ texty! ;
+: boardx! ( -- ) boardx textx! ;
+: boardy! ( -- ) boardy texty! ;
 : next-row ( -- ) nextline boardx! ;
 
-: draw-board-top tl boardw @ begin .- 1- dup while dT repeat tr drop next-row ;
+: draw-border ( end mid -- ) 
-: draw-board-bottom bl boardw @ begin .- 1- dup while uT repeat br drop next-row ;
+  boardw @ begin .- 1- dup while over execute repeat drop drop execute next-row ;
-: draw-rowborder rT boardw @ begin .- 1- dup while .+ repeat lT drop next-row ;
+: draw-board-top tl ' tr ' dT draw-border ;
+: draw-board-bottom bl ' br ' uT draw-border ;
+: draw-rowborder rT ' lT ' .+ draw-border ;
 : draw-row ( p -- p )
   .| begin dup draw-square .| 1+ dup square-pos drop not until next-row ;
 : draw-board ( -- )
@@ -93,7 +101,7 @@ array countcolors white b, lblue b, lgreen b, red b, blue b,
   drop draw-board-bottom ;
 
 0 var, reveal-state
-: reveal ( p -- ) dup b@ FREVEALED | swap b! ;
+: reveal ( p -- ) FREVEALED swap b!| ;
 : reveal-square? ( x y -- )
   square-at b@ FREVEALED = if -1 reveal-state ! then ;
 : reveal-pass ( -- f )
@@ -108,24 +116,56 @@ array countcolors white b, lblue b, lgreen b, red b, blue b,
 0 const IN-PROGRESS
 1 const WON
 2 const LOST
-IN-PROGRESS var, game-state
+3 const QUIT
+IN-PROGRESS bvar, game-state
 
 : check-win ( -- )
   0 board begin dup board-lim < while
     dup b@ dup FMINE & swap FREVEALED & or not if swap 1+ swap then
-    1+ repeat drop not if WON game-state ! then ;
+    1+ repeat drop not if WON game-state b! then ;
 
 : on-reveal ( p -- )
-  b@ FMINE & if LOST game-state ! else check-win then ;
+  b@ FMINE & if LOST game-state b! else check-win then ;
 : autoreveal begin reveal-pass not until ;
-: reveal-at square-at dup reveal autoreveal on-reveal draw-board ;
+: reveal-at square-at dup reveal autoreveal on-reveal ;
-: flag-at square-at dup b@ FFLAG | swap b! draw-board ;
+: flag-at square-at FFLAG swap b!^ ;
+
+0 bvar, cursx 0 bvar, cursy
+
+: draw-cursor ( -- )
+  1 boxstyle! blue fg!
+  cursx b@ 2* boardx + textx!
+  cursy b@ 2* boardy + texty!
+  textx tl .- tr nextline textx!
+  textx .| dup 2 + textx! .| nextline textx!
+  bl .- br
+  0 boxstyle! white fg! ;
+
+: move-cursor ( dx dy -- )
+  cursy b@ + swap cursx b@ + swap 2dup valid-pos? 
+  if cursy b! cursx b! else drop drop then ;
+
+: curs@ cursx b@ cursy b@ ;
+0x21 const %f
+: await-command
+  wait-key key>scan 
+  dup %esc   = if QUIT game-state b! then
+  dup %left  = if -1  0 move-cursor then 
+  dup %right = if  1  0 move-cursor then
+  dup %up    = if  0 -1 move-cursor then
+  dup %down  = if  0  1 move-cursor then 
+  dup %f     = if curs@ flag-at then
+  dup %enter = swap %space = or if curs@ reveal-at then ;
+
+: play
+  begin game-state b@ IN-PROGRESS = while 
+  draw-board draw-cursor await-command repeat draw-board ;
 
 : start
   textmode
   reseed!
-  15 10 15 init-board
+  20 12 30 init-board
-  draw-board ;
+  play ;
 
 ' start ' main redefine
 

reasm.bat

@@ -1,2 +1,4 @@
 assemble.com < tinyjort.jrt
 tinyjort.com < assemble.jrt
+assemble < zipoff.jrt
+

zipoff.jrt

@@ -109,6 +109,7 @@ s" coredefs.jrt" loadfile
 :timm const CONST ;
 :timm var, VAR, ;
 :timm var 0 VAR, ;
+:timm bvar, ARRAY >t ;
 :timm array ARRAY ;
 :timm allot ALLOT ;
 :timm :asm :ASM ;