dialer/swine.jrt

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 }