diff --git a/swine.com b/swine.com index ca90f54..366ff19 100755 Binary files a/swine.com and b/swine.com differ diff --git a/swine.jrt b/swine.jrt index a526537..5a1710e 100755 --- a/swine.jrt +++ b/swine.jrt @@ -8,6 +8,17 @@ import random.jrt : b!^ ( f p -- ) dup b@ t >t >t >t >t >t DOES} theme ! ; -( cursor grid block mine flag bg ) - blue white black magenta red lgray deftheme win31 - white yellow black lmagenta yellow red deftheme hotdog - -win31 - -: draw-neighbour-count ( b -- ) - NEIGHBOUR-MASK & dup col-count - dup if [ key 0 lit ] + else drop [ key lit ] then draw-char ; -: 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 ; - -: pos>screen ( x y -- x y ) - swap pagew boardw @ - 2/ + - swap pageh boardh @ - 2/ + ; -: 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 @ 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 ( -- ) - col-grid col-bg boardx! boardy! draw-board-top - board begin draw-row dup square-pos valid-pos? while draw-rowborder repeat - drop draw-board-bottom ; - -0 const IN-PROGRESS -1 const WON -2 const LOST -3 const QUIT -IN-PROGRESS bvar, game-state - : lose LOST game-state b! board begin dup board-lim < while FREVEALED over b!| 1+ repeat drop ; @@ -155,12 +105,11 @@ IN-PROGRESS bvar, game-state 1+ repeat drop ; : check-win ( -- ) - game-state b@ IN-PROGRESS = if + in-progress? if 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 b! then then ; - : reveal-unflagged-neighbours? ( p -- ) dup square-pos count-surrounding-flags over squarecount = if square-pos ' reveal do-neighbour-squares else drop then ; @@ -168,6 +117,120 @@ IN-PROGRESS bvar, game-state if reveal-unflagged-neighbours? else reveal then autoreveal check-win ; : flag-at square-at dup revealed? not if FFLAG swap b!^ else drop then ; +( 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 ! ; +( cursor grid block mine flag bg ) + blue white black magenta red lgray deftheme win31 + white yellow black lmagenta yellow red deftheme hotdog + +win31 + +( minesweeper board drawing ) +: draw-neighbour-count ( b -- ) + NEIGHBOUR-MASK & dup col-count + dup if [ key 0 lit ] + else drop [ key lit ] then draw-char ; +: 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 @ 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 ( -- ) + col-grid col-bg boardx! boardy! draw-board-top + board begin draw-row dup square-pos valid-pos? while draw-rowborder repeat + drop draw-board-bottom ; + +( 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 -- ) + begin dup b@ dup while draw-char dup spacer 1+ repeat drop drop ; + +( menu subsystem ) +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 + 33 10 textxy! + textx 0 begin dup menu-size < while + dup draw-selection dup draw-option 1+ nextline over textx! repeat + drop drop ; + +: 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 + enter ; + +{ :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 + rot !t cell + !t ; } + +( minesweeper game UI ) 0 bvar, cursx 0 bvar, cursy : draw-cursor ( -- ) @@ -184,10 +247,11 @@ IN-PROGRESS bvar, game-state 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 %esc = if leave 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 @@ -195,71 +259,41 @@ IN-PROGRESS bvar, game-state dup %f = if curs@ flag-at then dup %enter = swap %space = or if curs@ reveal-at then ; -: play IN-PROGRESS game-state b! - begin game-state b@ IN-PROGRESS = while - draw-board draw-cursor await-command repeat draw-board ; +: result-message + 25 8 textxy! 0 hstyle! 1 vstyle! + 30 5 filled draw-box + 27 10 textxy! draw-spaced-text + wait-key drop ; -: start - textmode - reseed! - 20 12 30 init-board - play ; +: display-result + game-state b@ + dup WON = if cyan bg! yellow fg! s" YOU WON" result-message then + LOST = if brown bg! lred fg! s" YOU LOST" result-message then ; -' start ' main redefine +: play enter col-bg clear + begin in-progress? while draw-board draw-cursor await-command repeat + draw-board display-result enter ; + +: start 20 12 30 init-board play ; ( title menu ) array title-text t", SWINE MEEPER" -: 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 -- ) - begin dup b@ dup while draw-char dup spacer 1+ repeat drop drop ; - -2 cells const menu-optsize -2 const menu-size -array menu-options menu-optsize menu-size * allot - -: menu-option ( iopt -- p ) menu-optsize * menu-options + ; -: defmenu ( cp name iopt -- ) menu-option dup >rot ! cell + ! ; - -' start s" Start Game" 0 defmenu -' terminate s" Quit" 1 defmenu - -0 var, menu-selected - -: menu-activate menu-selected @ menu-option cell + @ execute ; - -: draw-selection ( iopt -- ) - menu-selected @ = if draw-mine else sp then sp ; -: draw-option ( iopt -- ) white fg! menu-option @ draw-text ; -: draw-menu - 33 10 textxy! - textx 0 begin dup menu-size < while - dup draw-selection dup draw-option 1+ nextline over textx! repeat - drop drop ; +3 :noname col-bg clear ; defmenu theme-menu +' win31 s" Classic 3.1" 0 defitem +' hotdog s" Hot Dog Stand" 1 defitem +' leave s" Done" 2 defitem : draw-title - blue bg! yellow fg! 32 fill-page - 17 3 textxy! title-text draw-spaced-text - draw-menu ; + blue bg! yellow fg! clear + 17 3 textxy! title-text draw-spaced-text ; -: menu-selected! ( i -- ) - dup 0 >= over menu-size < and if menu-selected ! else drop then ; -: menu-selected+! ( di -- ) menu-selected @ + menu-selected! ; +3 ' draw-title defmenu title-menu +' start s" Start Game" 0 defitem +' theme-menu s" Themes" 1 defitem +' leave s" Quit" 2 defitem -: await-menu - wait-key key>scan - dup %esc = if terminate then - dup %up = if -1 menu-selected+! then - dup %down = if 1 menu-selected+! then - %enter = if menu-activate then ; - -: title draw-title begin await-menu draw-menu again ; +: title textmode reseed! hidecursor title-menu textmode ; ' title ' main redefine