53759181d1 2011-10-24 crc: ( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ) 53759181d1 2011-10-24 crc: ( Hangman for Retro Console ) 53759181d1 2011-10-24 crc: ( * Main game logic. ) 53759181d1 2011-10-24 crc: ( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ) 53759181d1 2011-10-24 crc: ( Copyright [c] 2010-11, Marc Simpson ) 53759181d1 2011-10-24 crc: ( License: ISC ) 53759181d1 2011-10-24 crc: ( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ) 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: needs console' 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: ( File inclusion will only work if you're running retro from ) 53759181d1 2011-10-24 crc: ( the same directory as hangman. ) 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: include graphics.retro 53759181d1 2011-10-24 crc: include dict.retro 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: ( --[ Variables ]--------------------------------------------- ) 53759181d1 2011-10-24 crc: 6136ede88d 2011-12-06 crc: variables| target guessed lifeline this-char foul-count | 53759181d1 2011-10-24 crc: stages constant lives ( see graphics.retro ) 53759181d1 2011-10-24 crc: create foul-addr lives allot 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: ( --[ Offset Calculation ]------------------------------------ ) 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: ( Build an array with offsets for a given character in string ) 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: : offsets, ( c$- ) 53759181d1 2011-10-24 crc: withLength [ [ 2over @ = ] dip swap &, &drop if 1+ ] iter 53759181d1 2011-10-24 crc: 2drop ; 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: : offsets ( $c-an ) here 2rot swap offsets, here over - ; 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: ( --[ Allocation ]-------------------------------------------- ) 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: : unallot ( n- ) negate allot ; 53759181d1 2011-10-24 crc: : unarray ( an- ) nip unallot ; 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: ( --[ Masking ]----------------------------------------------- ) 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: ( The array contains offset information; set the guess string ) 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: : update-guessed ( $ offsets len - ) 53759181d1 2011-10-24 crc: [ 2over @ + @this-char swap ! 1+ ] times 2drop ; 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: : toGuess ( guessed target c - ) 53759181d1 2011-10-24 crc: dup !this-char offsets ( guessed offsets length ) 53759181d1 2011-10-24 crc: 2over [ &update-guessed dip ] dip unarray ; 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: : guessChar ( c- ) @guessed @target rot toGuess ; 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: ( --[ Printing ]---------------------------------------------- ) 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: : .target ( - ) @target puts ; 53759181d1 2011-10-24 crc: : .guessed ( - ) @guessed puts ; 53759181d1 2011-10-24 crc: : .input ( - ) @lifeline "Tries: (%d): " puts ; 53759181d1 2011-10-24 crc: : .fouls ( - ) "Fouls: " puts foul-addr puts ; 53759181d1 2011-10-24 crc: : .prompt ( - ) 0 0 ^console'at-xy .guessed cr .fouls cr .input ; 53759181d1 2011-10-24 crc: : .already ( - ) " [already guessed]" puts ; 53759181d1 2011-10-24 crc: : .correct ( - ) " [correct guess] " puts ; 53759181d1 2011-10-24 crc: : .graphic ( - ) lives @lifeline - 1- graphics + @ do ; 53759181d1 2011-10-24 crc: : .wrong ( - ) " [not present] " puts .graphic ; 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: ( --[ Guessing ]---------------------------------------------- ) 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: : 0<> ( x-f ) 0 = not ; 53759181d1 2011-10-24 crc: : has ( $c-f ) ^strings'findChar 0<> ; 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: : foul+ ( c- ) foul-addr @foul-count + ! foul-count ++ ; 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: : (guess) ( c- ) 53759181d1 2011-10-24 crc: @guessed over has 53759181d1 2011-10-24 crc: [ .already ] 53759181d1 2011-10-24 crc: [ @target over has 53759181d1 2011-10-24 crc: [ dup guessChar .correct ] 53759181d1 2011-10-24 crc: [ foul-addr over has 53759181d1 2011-10-24 crc: [ .already ] 53759181d1 2011-10-24 crc: [ dup foul+ lifeline -- .wrong ] if ] if ] if drop ; 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: : guess ( - ) .prompt getc &putc &(guess) bi ; 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: ( --[ Game Logic ]-------------------------------------------- ) 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: : _string ( n-$ ) here swap [ '_ , ] times 0 , ; 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: : >target ( $- ) withLength swap !target _string !guessed ; 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: : 0fouls ( - ) 0 !foul-count 53759181d1 2011-10-24 crc: foul-addr lives [ 0 over ! 1+ ] times drop ; 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: : revive ( - ) lives !lifeline 0fouls ; 53759181d1 2011-10-24 crc: : remaining ( -f ) guessed @ '_ has ; 53759181d1 2011-10-24 crc: : alive ( -f ) remaining lifeline @ 0<> and ; 53759181d1 2011-10-24 crc: : dead? ( -f ) alive not ; 53759181d1 2011-10-24 crc: : foot ( - ) 0 20 ^console'at-xy ; 53759181d1 2011-10-24 crc: : .lose ( - ) foot "You LOSE; the word was: " puts .target ; 53759181d1 2011-10-24 crc: : .win ( - ) foot .target "\nYou WIN!" puts ; 53759181d1 2011-10-24 crc: : endgame ( - ) @lifeline &.win &.lose if ; 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: : (hangman) ( - ) clear repeat dead? if; guess again ; 53759181d1 2011-10-24 crc: : hangman ( $- ) >target revive (hangman) endgame ; 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: ( --[ Main Game ]--------------------------------------------- ) 53759181d1 2011-10-24 crc: 53759181d1 2011-10-24 crc: : y-or-n ( -f ) getc [ 'y = ] [ 'Y = ] bi or ; 53759181d1 2011-10-24 crc: : .again? ( -f ) "\n\nPlay again? [Y/N] " puts y-or-n ; 53759181d1 2011-10-24 crc: : play ( - ) 53759181d1 2011-10-24 crc: initialise @dict 0; drop 53759181d1 2011-10-24 crc: repeat get-word hangman .again? [ close-dict bye ] ifFalse again ; 53759181d1 2011-10-24 crc: ( ============================================================ ) 53759181d1 2011-10-24 crc: play