mineswpr : minesweeper for retro

Table of Contents

1 language tweaks

1.1 misc

( -- language tweaks --------------------------------------- )

: ≥ >= ; "( xy-? ) tests for x ≥ y . same as >=" :doc
: ≤ <= ; "( xy-? ) tests for x ≤ y . same as <=" :doc
: ≠ != ; "( xy-f ) just a fancy way to say !=" :doc
: dec ( a- ) -- ;
: inc ( a- ) ++ ;
: shl << ;
: shr >> ;
: odd 1 and 0 != ;
: vars| ` variables| ;
: dup2 ( xy-xyxy ) over over ;
: recurse (  -  ) @last @d->xt , ; compile-only ( from forth.rx )
: spaces [ space ] times ; "( n- ) emit n spaces" :doc
: deep push over pop swap ;
  "( xyz-xyzx ) copies the 3rd item to the top of the stack. ( dup, over, deep... )" :doc
: cop pop dup push ;
  "( -n ) copies a value from the return stack" :doc
: nor or not ;
: drop3 drop drop drop ;
with math'
  : randint ( n-n ) random swap mod ;
without

1.2 debug tools

( -- debug tools ------------------------------------------- )
with| vt' ng' |
{{
  : .? decimal push |y .s pop |Y puts |w ;
  variable depth
  : indent 2 * spaces ;
  : [context] last @ d->name lit,, ;
  : { cr depth dup ++ @ indent |M puts space '{ putc |w ;
  : } cr depth dup @ indent -- |M '} putc space puts |w ;
---reveal---
  : !! |R .s |r "!!" puts ;
  : ?{ [context] ` { ; immediate
  : }? [context] ` } ; immediate
  : ?? depth @ spaces [context] ` .? ; immediate
    "debug tool. at runtime, this will show the stack plus the name of the word in which it was used." :doc
}}
2without

1.3 imperative macros

( -- imperative flow control ------------------------------- )
with ng'
: ;c  ` ?? ` ; ` immediate ; immediate
{{ ( these two should *not* be immediate. they're called by immediates )
  : .come-from here swap ! ;
  : .else-ahead 0 lit,, 0 =jump,, here 1- ;
---reveal---
: .ifso .else-ahead  ;c                "c:  -a  | r:  f-   like IF in forth" :doc
: .else ahead push .come-from pop ;c   "c:  a-a | r:   -   forth-style ELSE" :doc
: .then   .come-from ;c                "c:  a-  | r:   -   like THEN in forth" :doc
: .repeat here ;c
: .while  here ;c
: .do  .else-ahead ;c
: .again
    push       ( push the location of the jump from .do  )
      jump,,   ( compile a jump to the position marked by .while )
    pop .come-from ;c
: .until 0 lit,, =jump,, ;c           "compile the UNTIL part of a repeat loop" :doc
}}
without

2 the game

2.1 DONE variables

( -- variables --------------------------------------------- )

enum| ·mine ·cover ·flag |
vars| gameOver? minefield flagCount active-cell |
vars| allHints? flood-cursor | ( debug stuff )

2.2 DONE grid-setup

16 constant W
16 constant H
24 constant mineCount
create grid W H * allot

: grid-size W H * ;

2.3 DONE point-methods

( point2d methods )
: nn 1- ; "( xy-xy ) north" :doc
: ss 1+ ; "( xy-xy ) south" :doc
: ee swap 1+ swap ; "( xy-xy ) east" :doc
: ww swap 1- swap ; "( xy-xy ) west" :doc
: ne nn ee ; "( xy-xy ) north-east" :doc
: se ss ee ; "( xy-xy ) south-east" :doc
: sw ss ww ; "( xy-xy ) south-west" :doc
: nw nn ww ; "( xy-xy ) north-west" :doc
{{
  : xy deep deep ;
  : qq deep do ;
---reveal---

  : cardinal-neighbors-do
                xy nn qq
    xy ww qq     ( xy )     xy ee qq
                xy ss qq               drop3 ;
   "( xyq- ) invoke q { xy-?? } for points to n,w,e,s" :doc

   : ordinal-neighbors-do
    xy nw qq                xy ne qq
                 ( xy )
    xy sw qq                xy se qq   drop3 ;
   "( xyq- ) invoke q { xy-?? } for points to nw,ne,sw,se" :doc

   : neighbors-do
    xy nw qq    xy nn qq    xy ne qq
    xy ww qq     ( xy )     xy ee qq
    xy sw qq    xy ss qq    xy se qq   drop3 ;
   "( xyq- ) invoke q { xy-?? } for all eight neighboring points" :doc

}}

: cell ( xy-a ) W * + grid + ;
  "( xy-a ) given coordinates, return the address of the cell" :doc

: inbounds? 0 H 1- within .ifso 0 W 1- within .else drop ( W- ) 0 .then ;
  "( xy-f ) is the point somewhere inside the minefield?" :doc

2.4 DONE cell methods

( cell methods )
: has? swap @ swap in? ;
  "( ce- ) does cell c contain the element e?" :doc

: uncover ·cover @excl! ;
  "( c- ) remove the cover from cell c" :doc

: armed-neighbor-count @ 8 shr ;
  "( c-n )  number of armed neighbors ( 0..8 )" :doc

: armed-neighbor-add $100 swap +! ;
  "( c- )  increment count of armed neighbors ( 0..8 )" :doc

: c>xy  grid - W /mod ;
  "( c-xy ) given a cell, return its xy coordinates." :doc

: randcell W randint H randint cell ;
  "( -a ) return a cell from the grid, at random" :doc

2.5 DONE grid methods

( grid methods )
: .fill swap W H * fill ;
  "( gx- ) fill grid g with value x" :doc

: grid-do grid-size [ 1- grid + over do ] iterd drop ;
  "( q- ) for each cell in the grid, put the cell's address in tos and run q." :doc

2.6 DONE floodfill

: needs-visit? ·cover has? ;
  "( c-f ) should we call flood-visit! on this cell?" :doc

: keep-going? armed-neighbor-count 0 = ; "( c-f )" :doc

: flood-visit uncover ; "( c- ) actually fill the cell." :doc
: flood-step-hook ; "( - ) just a hook for debugging " :doc

: flood
  ( check bounds before calling 'cell' b/c 'cell c>xy' allows horizontal wrapping )
  dup2 inbounds?
    .ifso cell
    dup flood-cursor ! flood-step-hook ( debug hook )
    dup needs-visit?
      .ifso
        dup flood-visit
        dup keep-going?
          .ifso c>xy [ flood ] cardinal-neighbors-do
          .else drop
          .then
      .else drop
      .then
    .else 2drop
    .then
  0 flood-cursor ! ;
  "( xy- ) runs the floodfill algorithm on the grid at the given cell" :doc

2.7 DONE event handlers

( -- event handlers ---------------------------------------------- )

  : «dead» gameOver? on ;
    "( a- ) called after detonating cell a" :doc

  : mineswpr-exit-hook ( revectored ) ;

2.8 DONE user actions

( -- user actions ---------------------------------------------- )

: flaggable? [ ·flag has? not ] [ ·cover has? ] bi and ;
  "( a-f ) possible to put a flag on this cell?" :doc

: flag+
  dup flaggable?
    .ifso ·flag @incl! flagCount ++
    .else drop
  .then ;
  "( a- ) place a flag on the cell" :doc

: flag-
  dup ·flag has?
    .ifso
      ·flag @excl!
      flagCount --
    .else drop
  .then ;
  "( a- ) remove the flag from the cell, if present" :doc

: prod
  dup flag-
  dup ·mine has?
    .ifso drop «dead»
    .else c>xy flood
  .then ;
  "( c- ) prod the cell for a mine, and see what happens... :)" :doc

2.9 DONE minefield words

( -- minefield words --------------------------------------- )

: hints-create
  [ dup ·mine has?
      .ifso
        c>xy
        [ dup2 inbounds?
            .ifso cell armed-neighbor-add
            .else drop drop
          .then
        ] neighbors-do
      .else drop
    .then
  ] grid-do ;
  "( - ) generate the armed-neighbor-count for each cell on the grid" :doc

: mine-add
  randcell
  dup ·mine has?
    .ifso drop recurse
    .else ·mine @incl!
  .then ;
  "( - ) add a mine to a random cell that doesn't yet have one" :doc

: game-new
  ·cover as-bit grid .fill
  mineCount [ mine-add ] times
  hints-create
  0 flagCount !
  gameOver? off ;
  "( - ) set up a new game" :doc

2.10 DONE draw the cells

with vt' with ng'

  variable set-bracket-color

  : |? set-bracket-color @ do ;
  : . putc ; : $ puts ;

  : show-flood-cursor
    flood-cursor @ = .ifso [ |M ] set-bracket-color ! .then ;
  : show-active-cell
    active-cell @ =
    .ifso
      [ |m ] set-bracket-color !
      0 active-cell !
    .then ;

  : |[ [ show-active-cell ] [ show-flood-cursor ] bi |? '[ putc ;
  : |] |? '] putc ;
  : hide-brackets [ |k ] set-bracket-color ! ;

  : hint armed-neighbor-count ;

  : mine-draw hide-brackets  |[ |r 'X . |] ;
  : flag-draw                |[ |R '! . |] ;
  : hint-draw hide-brackets
    dup hint dup 0 =
    .ifso drop               |[ |b '- .   |]
    .else push               |[ |B pop '0 + . |]
    .then ;
  : cover-draw
    allHints? @
      .ifso    hint-draw
      .else                  |[ |w '- . |] ;
    .then ;

  : make-striped
    odd .ifso [ |K ] .else [ |c ] .then set-bracket-color ! ;
    "( y- ) assign set-bracket-color based on line number" :doc

  : (x,y) dup make-striped cell
    dup show-flood-cursor
    dup @
    [ [ ·mine in? gameOver? @ and ]   [ mine-draw  ] whend
      [ ·flag  in? ]                  [ flag-draw  ] whend
      [ ·cover in? ]                  [ cover-draw ] whend
      [ drop   -1  ]                  [ hint-draw  ] whend ] do
   space ;
   "( xy- ) output cell as a string" :doc

  : show cr |C
    "     0   1   2   3   4   5   6   7   8   9   A   B   C   D   E   F   "
    puts cr
    H [ dup 2 spaces hex dup odd [ |w ] [ |C ] if putn space
          W [ over (x,y) ] iter cr drop ] iter ;
    "draw the minefield" :doc

2without

2.11 DONE draw the playing field

( -- display words -------------------------------------------- )
with vt'

: draw clear
  gameOver? @
  .ifso |R
    "                              GAME OVER! " $
  .else |Y
    "                            MINESWPR.RXE" $
  .then |b cr
    "-------------------------------------------------------------------" $ |w
  show
    cr |g "type cmd at '"
     $ |w "ok"
     $ |g "':  "
     $ |Y '+ . |c " = flag  "
     $ |Y '- . |c " = unflag  "
     $ |Y '? . |c " = prod for mine "
     $ |Y 'q . |c " = quit" $
    cr |g "cmd format: "
     $ |Y "x y "
     $ |c '[
     . |Y "+-?"
     $ |c '] . "   "
     $ |g "examples: "
     $ |w "5 C +"
     $ |y " a b -"
     $ |W " 2 9 ?"
     $ |R " q"
     $ |Y "   r "
     $ |c "= restart "
     $ |b cr
    "-------------------------------------------------------------------" $ |K
  .s gameOver? @
  .ifso |R "game over."
      $ |r " type "
      $ |y 'r
      . |r "  to restart" $
  .then
     cr |W "ok " $ |w
  ; "( - ) draw the mineswpr ui / prompt" :doc

without

2.12 DONE command parser

chain: mswp' "minesweeper parser" :doc

  : with-cell cell dup active-cell ! ;
  : if-cell-ok push
    depth 2 >=
    .ifso
       dup2 inbounds?
       .ifso with-cell pop do
       .else pop drop3
       .then
    .then ;

  ( ui command syntax )

  : + [ flag+ ] if-cell-ok ;
  : - [ flag- ] if-cell-ok ;
  : ? [ prod ]  if-cell-ok ;
  : a $A ;   : b $B ;   : c $C ;
  : d $D ;   : e $E ;   : f $F ;
  : r game-new ;
  : q mineswpr-exit-hook ;

;chain

2.13 DONE retro shell enhancements

( -- retro shell enhancements ------------------------------ )
with vt' with color'
: welcome
  clear
  |W "Welcome to Retro!" $ cr
  |w "Type " $ |Y "words " $
  |w "to see a list of words you can try, or " $
  |Y "play " $ |w "to play the game again." $ |w cr ;
  "a rudimentary welcome message." :doc
{{
  : mineswpr-play
    &draw &ok :is
    reset hex
    game-new
    "mswp'" find [ d->xt @ :with ] ifTrue ;

  : mineswpr-quit
    without
    reset decimal
    &grok &ok :is
    welcome ;

  &mineswpr-quit &mineswpr-exit-hook :is
---reveal---

  : play mineswpr-play ;
    "( - ) play minesweeper" :doc
}}
2without

3 OUTPUT

needs sets' needs vt'  needs math'
<<lang-tweaks>>

( == minesweeper game ====================================== )
with sets'
<<variables>>
<<grid-setup>>
<<point-methods>>
<<cell-methods>>
<<grid-methods>>
<<floodfill>>
<<events>>
<<user-actions>>
<<minefield-words>>
<<draw-cells>>
<<draw-field>>
<<cmd-parser>>
<<shell-tweaks>>

game-new

with vt'
: (xy) |c '( putc |g swap putn |c ", " |g puts putn  |c ') putc |w ;
  "( xy- ) output coordinate pair as a string" :doc
without

: on-flood-step clear
  !! space flood-cursor @ c>xy (xy)
  show getc 'q = .ifso bye .then ; "( - ) floodfill debugger" :doc
( &on-flood-step  &flood-step-hook :is )
play

4 TODO refile these

4.1 objects

method push ;
self pop dup push ;
end pop drop ;

4.2 virtual terminal words

chain: vt'

 |!k 0 vt:bg ; : |!r 1 vt:bg ; : |!g 2 vt:bg ; : |!y 3 vt:bg ;
 |!b 4 vt:bg ; : |!m 5 vt:bg ; : |!c 6 vt:bg ; : |!w 7 vt:bg ;