dialer/swine.jrt

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! ;
: ~ 0xffff ^ ;

30 const maxw 12 const maxh
array board maxw maxh * allot

10 var, boardw 
10 var, boardh
15 var, minecount

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

: reset-board
  board begin dup board-lim < while 0 over b! 1+ repeat drop ;
: populate-board
  minecount @ begin rand-mine 1- dup not until drop ;
: mine? ( p -- f )       b@ FMINE & ;
: flag? ( p -- f )       b@ FFLAG & ;
: revealed? ( p -- f )   b@ FREVEALED & ;
: squarecount ( p -- c ) b@ NEIGHBOUR-MASK & ;

: do-at ( x y cp -- )
  >rot 2dup valid-pos? if square-at swap execute else drop drop drop then ;
: do-neighbour-squares ( x y cp -- )
  >r over 1- over 1- r@ do-at
     over 1- over    r@ do-at
     over 1- over 1+ r@ do-at
     over    over 1- r@ do-at
     over    over 1+ r@ do-at
     over 1+ over 1- r@ do-at
     over 1+ over    r@ do-at
     swap 1+ swap 1+ <r do-at ;

var neighbour-count
var neighbour-check

: count-neighbour neighbour-check @ execute if 1 neighbour-count !+ then ;
: count-neighbours ( x y cp -- ) neighbour-check ! 0 neighbour-count ! 
  ' count-neighbour do-neighbour-squares neighbour-count @ ;

: analyze-pos ( x y -- n ) ' mine? count-neighbours ;
: analyze-board
  board begin dup board-lim < while 
    dup square-pos analyze-pos over b@ | over b! 1+ repeat drop ;

: count-surrounding-flags ( x y -- n ) ' flag? count-neighbours ;

: init-board ( w h minecount -- )
  minecount ! boardh ! boardw !
  reset-board populate-board analyze-board ;

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

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

: reveal ( p -- ) dup flag? not if 
    dup mine? if lose then FREVEALED swap b!| 
  else drop then  ;

: visibly-empty? dup revealed? swap squarecount not and ;
: backtrack-square ( p -- p ) boardw @ - 1- dup board < if drop board then ;
: backtrack? ( p -- f ) 
  dup revealed? over 1+ revealed? and swap 2 + revealed? and not ;
: autoreveal-backtrack ( p -- p )
  dup visibly-empty? over backtrack-square backtrack? and
  if backtrack-square 1- then ;
: autoreveal ( -- )
  board begin dup board-lim < while
    dup revealed? not if
      dup square-pos ' visibly-empty? count-neighbours
      if dup reveal autoreveal-backtrack then then
    1+ repeat drop ;

: check-win ( -- )
  game-state b@ 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 ;
: reveal-at square-at dup revealed? 
  if reveal-unflagged-neighbours? else reveal then autoreveal check-win ;
: flag-at square-at dup revealed? not if FFLAG swap b!^ else drop then ;

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
  0 boxstyle! ;

: 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 IN-PROGRESS game-state b!
  begin game-state b@ IN-PROGRESS = while 
  draw-board draw-cursor await-command repeat draw-board ;

: start
  textmode
  reseed!
  20 12 30 init-board
  play ;

' start ' main redefine

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

: draw-title 
  blue bg! yellow fg! 32 fill-page
  17 3 textxy! title-text draw-spaced-text 
  draw-menu ;

: menu-selected! ( i -- )
  dup 0 >= over menu-size < and if menu-selected ! else drop then ;
: menu-selected+! ( di -- ) menu-selected @ + menu-selected! ;

: 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 ' main redefine

{ s" swine.com" writecom }