424 lines
13 KiB
Plaintext
Executable file
424 lines
13 KiB
Plaintext
Executable file
dbg" start"
|
|
|
|
: digit ( n -- ) [ key 0 lit ] + draw-char ;
|
|
|
|
: meep 2000 5 -80 slide ;
|
|
: meeeep 2000 16 -50 slide ;
|
|
: moop 1600 5 80 slide ;
|
|
: boom 40 noise ;
|
|
: click 2000 3 boop 4000 3 boop ;
|
|
|
|
0 const IN-PROGRESS
|
|
1 const CANCEL
|
|
2 const WON
|
|
3 const LOST
|
|
4 const QUIT
|
|
IN-PROGRESS bvar, game-state
|
|
|
|
: leave CANCEL game-state b! ;
|
|
: enter IN-PROGRESS game-state b! ;
|
|
: in-progress? game-state b@ IN-PROGRESS = ;
|
|
: cancelled? game-state b@ CANCEL = ;
|
|
: uncancel cancelled? if enter then ;
|
|
|
|
( minesweeper board model )
|
|
dbg" minesweeper board model"
|
|
30 const maxw 12 const maxh
|
|
array board maxw maxh * allot
|
|
|
|
20 var, boardw
|
|
12 var, boardh
|
|
30 var, minecount
|
|
0xffff var, dirty-rows
|
|
|
|
: dirty! ( -- ) 0xffff dirty-rows ! ;
|
|
( mark both the current row and the row above, to ensure all borders are
|
|
redrawn )
|
|
: dirty-row! ( y -- ) 1 swap << dup 1 >> | dirty-rows @ | dirty-rows ! ;
|
|
: dirty-row? ( y -- f ) 1 swap << dirty-rows @ & ;
|
|
: draw-complete 0 dirty-rows ! ;
|
|
|
|
: board-lim boardw @ boardh @ * board + ;
|
|
: square-at ( x y -- p ) boardw @ * + board + ;
|
|
: square-pos ( p -- x y ) board - boardw @ /mod swap ;
|
|
|
|
: valid-pos? ( x y -- f )
|
|
dup 0 >= swap boardh @ < and
|
|
swap dup 0 >= swap boardw @ < and and ;
|
|
|
|
0x80 const FMINE
|
|
0x40 const FREVEALED
|
|
0x20 const FFLAG
|
|
0x0F const NEIGHBOUR-MASK
|
|
|
|
: place-mine ( x y -- f )
|
|
square-at dup b@ FMINE & not if FMINE swap b! 0 then not ;
|
|
: rand-mine ( -- )
|
|
begin rand boardw @ % rand boardh @ % place-mine until ;
|
|
|
|
: iterboard board board-lim for ;
|
|
: iterrows board board-lim boardw @ for+ ;
|
|
: lastrow? ( p -- f ) board-lim boardw @ - >= ;
|
|
: reset-board iterboard each 0 i b! next ;
|
|
: populate-board minecount @ times each rand-mine next ;
|
|
|
|
: mine? ( p -- f ) b@ FMINE & ;
|
|
: flag? ( p -- f ) b@ FFLAG & ;
|
|
: revealed? ( p -- f ) b@ FREVEALED & ;
|
|
: squarecount ( p -- c ) b@ NEIGHBOUR-MASK & ;
|
|
|
|
: 8-neighbours ( x y -- ) >arg >arg ((
|
|
over 1- over 1- yield2
|
|
over 1- over yield2
|
|
over 1- over 1+ yield2
|
|
over over 1- yield2
|
|
over over 1+ yield2
|
|
over 1+ over 1- yield2
|
|
over 1+ over yield2 -arg -arg
|
|
swap 1+ swap 1+ yield2 )) ;
|
|
|
|
: neighbours ( p -- ) square-pos 8-neighbours
|
|
(( each i j valid-pos? if i j square-at map then next )) ;
|
|
|
|
: count-neighbours ( p cp -- n )
|
|
>r neighbours 0 each i r@ execute if 1+ then next rdrop ;
|
|
|
|
: analyze-square ( p -- n ) ' mine? count-neighbours ;
|
|
: analyze-board iterboard each i analyze-square i b!| next ;
|
|
|
|
: count-surrounding-flags ( p -- n ) ' flag? count-neighbours ;
|
|
|
|
: init-board ( -- )
|
|
reset-board populate-board analyze-board ;
|
|
|
|
: lose LOST game-state b!
|
|
iterboard each FREVEALED i b!| next ;
|
|
|
|
: reveal ( p -- ) dup flag? not if
|
|
dup mine? if lose then FREVEALED swap b!|
|
|
else drop then ;
|
|
|
|
var autoreveal-count
|
|
( autoreveal: Happens row-at-a-time in optimized machine code.
|
|
ar-check-dir: a strip of squares is checked for visibly empty neighbours
|
|
against its corresponding square in a given direction, specified with BX.
|
|
autoreveal-count is incremented whenever a new square is revealed.
|
|
The strips are carefully constructed so as to not step over the edge of
|
|
the board.
|
|
This is _not_ a Forth word, it's called with CALL by the words below.
|
|
autoreveal-row-above: check the nw, n, and ne squares with ar-check-dir.
|
|
autoreveal-row-horiz: check the w and e squares with ar-check-dir.
|
|
autoreveal-row-below: check the sw, s, and se squares with ar-check-dir.
|
|
autoreveal-fast: iterates over the rows of the board and checks each row
|
|
against itself and the strips above and below. If anything new is
|
|
autorevealed in the current row, we check the previous row again. )
|
|
|
|
L: ar-check-dir
|
|
( in: DI - row to reveal
|
|
BX - offset of row to check
|
|
CH - 0, CL - count of squares to check
|
|
out: DI, BX, CX - preserved
|
|
trampled: AX, DX )
|
|
MOV AX DS
|
|
MOV ES AX
|
|
MOV AL FREVEALED # ( AL - byte value of visibly empty square )
|
|
( DI is now row to check, BX+DI is row to reveal )
|
|
MOV DH CL
|
|
ADD DI BX
|
|
NEG BX
|
|
DEC BX ( DI will be one past the square that was checked when SCASB returns )
|
|
0 :>
|
|
JCXZ 2 @> ( end of row, exit )
|
|
REPNZ SCASB ( search for visibly empty square )
|
|
JNZ 1 @> ( none found, exit )
|
|
MOV DL @[ BX+DI]
|
|
TEST DL AL
|
|
JNZ 0 <@ ( already revealed, keep searching )
|
|
OR DL AL
|
|
AND DL FFLAG ~ #
|
|
MOV @[ BX+DI] DL
|
|
INC @[ autoreveal-count @]
|
|
JMP 0 <@
|
|
1 <: 2 <:
|
|
( revert DI, BX and CX to previous value )
|
|
MOV CL DH
|
|
SUB DI CX
|
|
INC BX
|
|
ADD DI BX
|
|
NEG BX
|
|
RET
|
|
|
|
:asm autoreveal-row-above ( p -- )
|
|
POP DI
|
|
MOV CX @[ boardw @]
|
|
MOV BX CX NEG BX ( directly above )
|
|
CALL ar-check-dir
|
|
L: autoreveal-left-right
|
|
DEC CX INC BX ( to the right )
|
|
CALL ar-check-dir
|
|
DEC BX DEC BX INC DI ( to the left )
|
|
CALL ar-check-dir
|
|
NEXT
|
|
|
|
:asm autoreveal-row-horiz ( p -- )
|
|
POP DI
|
|
MOV CX @[ boardw @]
|
|
XOR BX BX ( on the current square )
|
|
JMP autoreveal-left-right
|
|
|
|
:asm autoreveal-row-below ( p -- )
|
|
POP DI
|
|
MOV CX @[ boardw @]
|
|
MOV BX CX ( directly below )
|
|
CALL ar-check-dir
|
|
JMP autoreveal-left-right
|
|
|
|
: autoreveal-fast
|
|
iterrows each
|
|
0 autoreveal-count !
|
|
i autoreveal-row-horiz
|
|
i board > if i autoreveal-row-above then
|
|
i lastrow? not if i autoreveal-row-below then
|
|
i board > autoreveal-count @ and if
|
|
( backtrack ) <i boardw @ 2* - >i
|
|
then
|
|
next ;
|
|
|
|
: won? ( -- f )
|
|
1 iterboard each i b@ FMINE FREVEALED | & not if not break then next ;
|
|
: check-win ( -- ) in-progress? if won? if WON game-state b! then then ;
|
|
|
|
: reveal-unflagged-neighbours? ( p -- )
|
|
dup count-surrounding-flags over squarecount =
|
|
if click neighbours each i reveal next else drop then ;
|
|
: reveal-at square-at dup revealed?
|
|
if reveal-unflagged-neighbours? else reveal click then
|
|
autoreveal-fast check-win ;
|
|
: flag-noise ( p -- ) b@ FFLAG & if moop else meep then ;
|
|
: flag-at square-at dup revealed? not
|
|
if FFLAG swap dup flag-noise b!^ else drop then ;
|
|
|
|
( theming )
|
|
dbg" theming"
|
|
array countcolors white b, lblue b, lgreen b, red b, blue b,
|
|
brown b, cyan b, black b, gray b,
|
|
|
|
var theme
|
|
: colvar theme @ + b@ ;
|
|
: col-bg 0 colvar bg! ;
|
|
: col-flag 1 colvar fg! ;
|
|
: col-mine 2 colvar fg! ;
|
|
: col-block 3 colvar fg! ;
|
|
: col-grid 4 colvar fg! ;
|
|
: col-curs 5 colvar fg! ;
|
|
: col-count ( c -- )
|
|
countcolors + b@ dup 0 colvar = if drop col-grid else fg! then ;
|
|
|
|
{ :timm deftheme CREATE >t >t >t >t >t >t DOES} theme !save ;
|
|
( cursor grid block mine flag bg )
|
|
blue white black magenta red lgray deftheme win31
|
|
white yellow black lmagenta yellow red deftheme hotdog
|
|
yellow lgray cyan lmagenta yellow blue deftheme borland
|
|
magenta lgray magenta magenta magenta cyan deftheme cga4
|
|
win31
|
|
|
|
( minesweeper board drawing )
|
|
dbg" board drawing"
|
|
: draw-neighbour-count ( b -- )
|
|
NEIGHBOUR-MASK & dup col-count
|
|
dup if digit else drop [ key lit ] draw-char then ;
|
|
: draw-flag ( -- ) col-flag 0x0d draw-char ;
|
|
: draw-mine ( -- ) col-mine 0xec draw-char ;
|
|
: draw-block ( -- ) col-block 0xb1 draw-char ;
|
|
: draw-revealed ( b -- )
|
|
dup FMINE & if draw-mine drop else draw-neighbour-count then ;
|
|
: draw-hidden ( b -- )
|
|
FFLAG & if draw-flag else draw-block then ;
|
|
: draw-square ( p -- )
|
|
b@ dup FREVEALED & if draw-revealed else draw-hidden then col-grid ;
|
|
|
|
: 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-border ( end mid -- )
|
|
boardw @ times each .- i if dup execute then next 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 -- )
|
|
.| boardw @ times each dup draw-square 1+ .| next drop next-row ;
|
|
: draw-board ( -- ) 0 boxstyle!
|
|
col-grid col-bg boardx! boardy! draw-board-top
|
|
iterrows each i dirty-row? not if
|
|
i draw-row i lastrow? not if draw-rowborder then
|
|
else
|
|
next-row i lastrow? not if next-row then
|
|
then next draw-board-bottom draw-complete ;
|
|
|
|
( general-purpose drawing )
|
|
dbg" general-purpose drawing"
|
|
: clear [ key lit ] fill-page ;
|
|
|
|
: emptych? ( ch -- f ) dup 32 = swap 0 = or ;
|
|
: drawdot? ( st -- f ) dup b@ emptych? swap 1+ b@ emptych? or not ;
|
|
|
|
: dot 7 draw-char ;
|
|
: sp 32 draw-char ;
|
|
: spacer ( st -- ) sp drawdot? if dot else sp then sp ;
|
|
|
|
: draw-spaced-text ( st -- )
|
|
pchars each i b@ draw-char i spacer next ;
|
|
|
|
( menu subsystem )
|
|
dbg" menu"
|
|
2 cells const menu-optsize
|
|
var current-menu
|
|
: menu-options current-menu @ cell + 1+ ;
|
|
: menu-size current-menu @ cell + b@ ;
|
|
: init-menu current-menu @ @ execute ;
|
|
|
|
: menu-option ( iopt -- p ) menu-optsize * menu-options + ;
|
|
|
|
0 var, menu-selected
|
|
|
|
: menu-activate menu-selected @ menu-option cell + @ execute ;
|
|
: menu-selected! ( i -- )
|
|
dup 0 >= over menu-size < and if menu-selected ! else drop then ;
|
|
: menu-selected+! ( di -- ) menu-selected @ + menu-selected! ;
|
|
|
|
: draw-selection ( iopt -- )
|
|
menu-selected @ = if draw-mine else sp then sp ;
|
|
: draw-option ( iopt -- ) white fg! menu-option @ draw-text ;
|
|
: draw-menu
|
|
30 9 textxy!
|
|
textx 0 menu-size for each
|
|
i draw-selection i draw-option nextline dup textx!
|
|
next ;
|
|
|
|
: await-menu
|
|
wait-key key>scan
|
|
dup %esc = if leave then
|
|
dup %up = if -1 menu-selected+! then
|
|
dup %down = if 1 menu-selected+! then
|
|
%enter = if menu-activate init-menu then ;
|
|
|
|
: run-menu
|
|
enter init-menu
|
|
begin draw-menu await-menu in-progress? not until
|
|
uncancel ;
|
|
|
|
{ :timm defmenu ( itemcount cpinit -- )
|
|
CREATE target current-menu !t w>t dup >t menu-optsize * ALLOT DOES}
|
|
menu-selected @ >r current-menu @ >r
|
|
current-menu ! 0 menu-selected! run-menu
|
|
<r current-menu ! <r menu-selected! ;
|
|
|
|
{ :timm defitem ( cp name iopt -- ) menu-option dup >rot !t cell + !t ; }
|
|
|
|
( minesweeper game UI )
|
|
dbg" game ui"
|
|
0 bvar, cursx 0 bvar, cursy
|
|
|
|
: draw-cursor ( -- )
|
|
1 boxstyle! col-curs
|
|
cursx b@ 2* boardx + textx!
|
|
cursy b@ 2* boardy + texty!
|
|
textx tl .- tr nextline textx!
|
|
textx .| dup 2 + textx! .| nextline textx!
|
|
bl .- br ;
|
|
|
|
: move-cursor ( dx dy -- )
|
|
cursy b@ dup dirty-row! + swap cursx b@ + swap 2dup valid-pos?
|
|
if cursy b! cursx b! else drop drop then cursy b@ dirty-row! ;
|
|
|
|
: curs@ cursx b@ cursy b@ ;
|
|
|
|
0x21 const %f
|
|
: await-command
|
|
wait-key key>scan
|
|
dup %esc = if leave dirty! 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 cursy b@ dirty-row! then
|
|
dup %enter = swap %space = or if curs@ reveal-at dirty! then ;
|
|
|
|
: popupbox ( h -- )
|
|
20 8 textxy! 0 hstyle! 1 vstyle!
|
|
39 swap filled draw-box ;
|
|
|
|
: result-message ( st x -- )
|
|
5 popupbox ( x ) 10 textxy! draw-spaced-text
|
|
wait-key drop ;
|
|
|
|
: beat 10 sleep-csec ;
|
|
: fanfare meep beat moop beat meep beat moop beat meep beat meep beat meeeep ;
|
|
: display-result
|
|
game-state b@
|
|
dup WON = if fanfare green bg! lcyan fg! s" YOU WON" 26 result-message then
|
|
LOST = if boom red bg! yellow fg! s" YOU LOST" 25 result-message then ;
|
|
|
|
2 :noname blue bg! lgray fg! 4 popupbox ; defmenu quitmenu
|
|
' leave s" Return to game" 0 defitem
|
|
:noname QUIT game-state b! ; s" Quit to title" 1 defitem
|
|
|
|
: confirm-quit cancelled? if quitmenu col-bg clear then ;
|
|
: draw-game draw-board draw-cursor ;
|
|
|
|
: play enter col-bg clear dirty!
|
|
begin draw-game await-command confirm-quit in-progress? not until
|
|
dirty! draw-board display-result enter ;
|
|
|
|
: start init-board boardw @ 2/ cursx b! boardh @ 2/ cursy b! play ;
|
|
|
|
( title menu )
|
|
dbg" title"
|
|
array title-text t", SWINE MEEPER"
|
|
|
|
5 :noname col-bg clear ; defmenu theme-menu
|
|
' win31 s" 3.11 for Worksties" 0 defitem
|
|
' hotdog s" Pork Sausage Stand" 1 defitem
|
|
' borland s" Boarland Turbohog" 2 defitem
|
|
' cga4 s" Sowlo Jazz" 3 defitem
|
|
' leave s" Done" 4 defitem
|
|
|
|
20 12 30 minecount ! boardh ! boardw !
|
|
: config-game ( boardw boardh minecount -- )
|
|
minecount !save boardh !save boardw !save leave ;
|
|
|
|
3 :noname red bg! clear ; defmenu difficulty-menu
|
|
:noname 10 10 10 config-game ; s" Easy ( 10x10, 10 truffles )" 0 defitem
|
|
:noname 20 12 30 config-game ; s" Moderate ( 20x12, 30 truffles )" 1 defitem
|
|
:noname 30 12 60 config-game ; s" Hard ( 30x12, 60 truffles )" 2 defitem
|
|
|
|
: draw-title
|
|
blue bg! yellow fg! clear
|
|
17 3 textxy! title-text draw-spaced-text ;
|
|
|
|
import embed.jrt
|
|
array instructiontext { s" swine.txt" embed }
|
|
|
|
: instructions
|
|
lgray bg! blue fg! clear
|
|
2 1 textxy!
|
|
instructiontext dup embed-data swap @ for each
|
|
i b@ dup 32 >= if draw-char else 10 = if 2 texty 1+ textxy! then then
|
|
next wait-key drop ;
|
|
|
|
5 ' draw-title defmenu title-menu
|
|
' start s" Start Game" 0 defitem
|
|
' instructions s" Instructions" 1 defitem
|
|
' difficulty-menu s" Difficulty" 2 defitem
|
|
' theme-menu s" Themes" 3 defitem
|
|
' leave s" Quit" 4 defitem
|
|
|
|
' main :chain textmode reseed! hidecursor title-menu textmode ;
|
|
|
|
dbg" saving"
|
|
|
|
{ s" swine.com" writecom }
|