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: ( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ) 9f5aa980c6 2011-01-19 marc: ( Copyright [c] 2010-11, 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 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: 7058f95d8e 2010-10-25 crc: 5 elements target guessed lifeline this-char foul-count 7058f95d8e 2010-10-25 crc: stages constant lives ( see graphics.retro ) eca5386b7f 2010-05-31 charlesch: here lives allot constant foul-addr 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$- ) 9f5aa980c6 2011-01-19 marc: withLength [ [ 2dup @ = ] dip swap &, &drop if 1+ ] iter 180b240e3a 2010-11-16 crc: 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: ( --[ Allocation ]-------------------------------------------- ) eca5386b7f 2010-05-31 charlesch: 9f5aa980c6 2011-01-19 marc: : unallot ( n- ) 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 - ) 9f5aa980c6 2011-01-19 marc: [ 2dup @ + @this-char swap ! 1+ ] times 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 ; 7058f95d8e 2010-10-25 crc: : .input ( - ) @lifeline "Tries: (%d): " puts ; 720b103870 2010-09-19 charlesch: : .fouls ( - ) "Fouls: " puts foul-addr puts ; f07b468712 2010-11-16 crc: : .prompt ( - ) 0 0 ^console'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 ; 25b3671a47 2010-11-16 crc: : has ( $c-f ) ^strings'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: 9f5aa980c6 2011-01-19 marc: : (guess) ( c- ) 9f5aa980c6 2011-01-19 marc: @guessed over has 9f5aa980c6 2011-01-19 marc: [ .already ] 9f5aa980c6 2011-01-19 marc: [ @target over has 9f5aa980c6 2011-01-19 marc: [ dup guessChar .correct ] 9f5aa980c6 2011-01-19 marc: [ foul-addr over has 9f5aa980c6 2011-01-19 marc: [ .already ] 9f5aa980c6 2011-01-19 marc: [ dup foul+ lifeline -- .wrong ] if ] if ] if drop ; 9f5aa980c6 2011-01-19 marc: 9f5aa980c6 2011-01-19 marc: : guess ( - ) .prompt getc dup putc (guess) ; eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: ( --[ Game Logic ]-------------------------------------------- ) eca5386b7f 2010-05-31 charlesch: 9f5aa980c6 2011-01-19 marc: : _string ( n-$ ) here swap [ '_ , ] times 0 , ; eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: : >target ( $- ) 180b240e3a 2010-11-16 crc: withLength swap target ! _string guessed ! ; eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: : 0fouls ( - ) 0 foul-count ! 9f5aa980c6 2011-01-19 marc: foul-addr lives [ 0 over ! 1+ ] times 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 ; f07b468712 2010-11-16 crc: : foot ( - ) 0 20 ^console'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 ; 9f5aa980c6 2011-01-19 marc: : endgame ( - ) @lifeline &.win &.lose if ; 9f5aa980c6 2011-01-19 marc: 9f5aa980c6 2011-01-19 marc: : (hangman) ( - ) clear repeat dead if; guess again ; 9f5aa980c6 2011-01-19 marc: : hangman ( $- ) >target revive (hangman) endgame ; eca5386b7f 2010-05-31 charlesch: eca5386b7f 2010-05-31 charlesch: ( --[ Main Game ]--------------------------------------------- ) eca5386b7f 2010-05-31 charlesch: 9f5aa980c6 2011-01-19 marc: : y-or-n ( -f ) getc [ 'y = ] [ 'Y = ] bi 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 9f5aa980c6 2011-01-19 marc: repeat get-word hangman .again? [ close-dict bye ] ifFalse again ; eca5386b7f 2010-05-31 charlesch: ( ============================================================ ) 25b3671a47 2010-11-16 crc: play