small constants, keyboard input, interactive minesweeper

This commit is contained in:
Jeremy Penner 2023-09-23 22:44:30 -04:00
parent 133c2e370a
commit ecddfc5b1a
12 changed files with 126 additions and 36 deletions

View file

@ -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

Binary file not shown.

View file

@ -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

38
keys.jrt Executable file
View file

@ -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

View file

@ -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

BIN
mines.com

Binary file not shown.

View file

@ -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 -- )
mine-at? if curr-mine-count @ 1+ curr-mine-count ! then ;
: count-mine-at ( x y -- ) mine-at? if 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! ( -- ) pagew boardw @ 2* 1+ - 2/ textx! ;
: boardy! ( -- ) pageh boardh @ 2* 1+ - 2/ texty! ;
: boardx ( -- x ) pagew boardw @ 2* 1+ - 2/ ;
: boardy ( -- y ) pageh boardh @ 2* 1+ - 2/ ;
: 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-board-bottom bl boardw @ begin .- 1- dup while uT repeat br drop next-row ;
: draw-rowborder rT boardw @ begin .- 1- dup while .+ repeat lT drop next-row ;
: draw-border ( end mid -- )
boardw @ begin .- 1- dup while over execute repeat drop drop execute 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 ;
: flag-at square-at dup b@ FFLAG | swap b! draw-board ;
: reveal-at square-at dup reveal autoreveal on-reveal ;
: 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
draw-board ;
20 12 30 init-board
play ;
' start ' main redefine

View file

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

Binary file not shown.

Binary file not shown.

View file

@ -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 ;

Binary file not shown.