eca5386b7f 2010-05-31 charlesch: ( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ) eca5386b7f 2010-05-31 charlesch: ( Hangman for Retro Console ) eca5386b7f 2010-05-31 charlesch: ( * Main game logic. ) eca5386b7f 2010-05-31 charlesch: ( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ) eca5386b7f 2010-05-31 charlesch: ( Copyright [c] 2010, Marc Simpson ) eca5386b7f 2010-05-31 charlesch: ( License: ISC ) eca5386b7f 2010-05-31 charlesch: ( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ) eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: ( File inclusion will only work if you're running retro from ) eca5386b7f 2010-05-31 charlesch: ( the same directory as hangman. ) eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: include graphics.retro eca5386b7f 2010-05-31 charlesch: include dict.retro 8eafc4e897 2010-09-13 crc: 8eafc4e897 2010-09-13 crc: with strings' eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: ( --[ Macros ]------------------------------------------------ ) eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: : 2push ` push ` push ; compile-only eca5386b7f 2010-05-31 charlesch: : 2pop ` pop ` pop ; compile-only eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: ( --[ Variables ]--------------------------------------------- ) eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: variable target eca5386b7f 2010-05-31 charlesch: variable guessed eca5386b7f 2010-05-31 charlesch: 8eafc4e897 2010-09-13 crc: stages constant lives ( see graphics.retro ) eca5386b7f 2010-05-31 charlesch: variable lifeline eca5386b7f 2010-05-31 charlesch: variable this-char eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: here lives allot constant foul-addr eca5386b7f 2010-05-31 charlesch: variable foul-count eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: ( --[ Offset Calculation ]------------------------------------ ) eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: ( Build an array with offsets for a given character in string ) eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: : offsets, ( c$- ) eca5386b7f 2010-05-31 charlesch: dup getLength eca5386b7f 2010-05-31 charlesch: fori push 2dup @ =if pop , else rdrop then 1+ nexti eca5386b7f 2010-05-31 charlesch: 2drop ; eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: : offsets ( $c-an ) here -rot swap offsets, here over - ; eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: ( --[ Allocation ]-------------------------------------------- ) eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: : unallot ( - ) neg allot ; eca5386b7f 2010-05-31 charlesch: : unarray ( an- ) nip unallot ; eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: ( --[ Masking ]----------------------------------------------- ) eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: ( The array contains offset information; set the guess string ) eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: : update-guessed ( $ offsets len - ) 720b103870 2010-09-19 charlesch: for 2dup @ + @this-char swap ! 1+ next 2drop ; eca5386b7f 2010-05-31 charlesch: 8eafc4e897 2010-09-13 crc: : toGuess ( guessed target c - ) eca5386b7f 2010-05-31 charlesch: dup this-char ! offsets ( guessed offsets length ) eca5386b7f 2010-05-31 charlesch: 2dup 2push update-guessed 2pop unarray ; eca5386b7f 2010-05-31 charlesch: 720b103870 2010-09-19 charlesch: : guessChar ( c- ) @guessed @target rot toGuess ; eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: ( --[ Printing ]---------------------------------------------- ) eca5386b7f 2010-05-31 charlesch: 720b103870 2010-09-19 charlesch: : .target ( - ) @target puts ; 720b103870 2010-09-19 charlesch: : .guessed ( - ) @guessed puts ; 720b103870 2010-09-19 charlesch: : .input ( - ) "Tries: (" puts lifeline @ putn "): " puts ; 720b103870 2010-09-19 charlesch: : .fouls ( - ) "Fouls: " puts foul-addr puts ; eca5386b7f 2010-05-31 charlesch: : .prompt ( - ) 0 0 at-xy .guessed cr .fouls cr .input ; 720b103870 2010-09-19 charlesch: : .already ( - ) space "[already guessed]" puts ; 720b103870 2010-09-19 charlesch: : .correct ( - ) space "[correct guess] " puts ; e96ace507c 2010-09-12 charlesch: : .graphic ( - ) lives lifeline @ - 1- graphics + @ do ; 720b103870 2010-09-19 charlesch: : .wrong ( - ) space "[not present] " puts .graphic ; eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: ( --[ Guessing ]---------------------------------------------- ) eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: : 0<> ( x-f ) 0 = not ; 8eafc4e897 2010-09-13 crc: : has ( $c-f ) findChar 0<> ; eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: : foul+ ( c- ) foul-addr foul-count @ + ! 1 foul-count +! ; eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: : guess ( - ) eca5386b7f 2010-05-31 charlesch: .prompt key >lower dup emit push eca5386b7f 2010-05-31 charlesch: guessed @ r has if .already else 8eafc4e897 2010-09-13 crc: target @ r has if r guessChar .correct else eca5386b7f 2010-05-31 charlesch: foul-addr r has if .already else eca5386b7f 2010-05-31 charlesch: r foul+ lifeline -- .wrong then then then rdrop ; eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: ( --[ Game Logic ]-------------------------------------------- ) eca5386b7f 2010-05-31 charlesch: 0c2cfa8b8b 2010-07-25 charlesch: : _string ( n-$ ) here swap for '_ , next 0 , ; eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: : >target ( $- ) eca5386b7f 2010-05-31 charlesch: dup getLength swap target ! _string guessed ! ; eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: : 0fouls ( - ) 0 foul-count ! eca5386b7f 2010-05-31 charlesch: foul-addr lives for 0 over ! 1+ next drop ; eca5386b7f 2010-05-31 charlesch: 0c2cfa8b8b 2010-07-25 charlesch: : revive ( - ) lives lifeline ! 0fouls ; 0c2cfa8b8b 2010-07-25 charlesch: : remaining ( -f ) guessed @ '_ has ; eca5386b7f 2010-05-31 charlesch: : alive ( -f ) remaining lifeline @ 0<> and ; eca5386b7f 2010-05-31 charlesch: : dead ( -f ) alive not ; eca5386b7f 2010-05-31 charlesch: : foot ( - ) 0 20 at-xy ; 720b103870 2010-09-19 charlesch: : .lose ( - ) foot "You LOSE; the word was: " puts .target ; 720b103870 2010-09-19 charlesch: : .win ( - ) foot .target cr "You WIN!" puts ; eca5386b7f 2010-05-31 charlesch: : endgame ( - ) lifeline @ if .win else .lose then ; eca5386b7f 2010-05-31 charlesch: : (hangman) ( - ) clear repeat dead if endgame ;then guess again ; eca5386b7f 2010-05-31 charlesch: : hangman ( $- ) >target revive (hangman) ; eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: ( --[ Main Game ]--------------------------------------------- ) eca5386b7f 2010-05-31 charlesch: 0c2cfa8b8b 2010-07-25 charlesch: : y-or-n ( -f ) key dup 'y = swap 'Y = or ; 720b103870 2010-09-19 charlesch: : .again? ( -f ) cr cr "Play again? [Y/N] " puts y-or-n ; e96ace507c 2010-09-12 charlesch: : play ( - ) eca5386b7f 2010-05-31 charlesch: initialise dict @ 0; drop eca5386b7f 2010-05-31 charlesch: repeat get-word hangman .again? 0 =if close-dict bye then again ; eca5386b7f 2010-05-31 charlesch: ( ============================================================ ) 379d5b04d6 2010-07-14 charlesch: play