extra/24-game/24-game.factor

   1 ! Copyright © 2008 Reginald Keith Ford II
   2 ! 24, the Factor game!
   3
   4 USING: kernel random namespaces shuffle sequences
   5 parser io math prettyprint combinators continuations
   6 arrays words quotations accessors math.parser backtrack assocs ;
   7
   8 IN: 24-game
   9 SYMBOL: commands
  10 : nop ;
  11 : do-something ( a b -- c ) { + - * } amb-execute ;
  12 : maybe-swap ( a b -- a b ) { nop swap } amb-execute ;
  13 : some-rots ( a b c -- a b c )
  14     #! Try each permutation of 3 elements.
  15     { nop rot -rot swap spin swapd } amb-execute ;
  16 : makes-24? ( a b c d -- ? )
  17         [
  18             2 [ some-rots do-something ] times
  19             maybe-swap do-something
  20             24 =
  21         ]
  22         [ 4drop ]
  23     if-amb ;
  24 : q ( -- obj ) "quit" ;
  25 : show-commands ( -- ) "Commands: " write commands get unparse print ;
  26 : report ( vector -- ) unparse print show-commands ;
  27 : give-help ( -- ) "Command not found..." print show-commands ;
  28 : find-word ( string choices -- word ) [ name>> = ] with find nip ;
  29 : obtain-word ( -- word )
  30     readln commands get find-word dup
  31     [ drop give-help obtain-word ] unless ;
  32 : done? ( vector -- t/f ) 1 swap length = ;
  33 : victory? ( vector -- t/f ) { 24 } = ;
  34 : apply-word ( vector word -- array ) 1quotation with-datastack >array ;
  35 : update-commands ( vector -- )
  36     length 3 <
  37         [ commands [ \ rot swap remove ] change ]
  38         [ ]
  39     if ;
  40 DEFER: check-status
  41 : quit-game ( vector -- ) drop "you're a quitter" print ;
  42 : quit? ( vector -- t/f ) peek "quit" = ;
  43 : end-game ( vector -- )
  44     dup victory?
  45         [ drop "You WON!" ]
  46         [ pop number>string " is not 24... You lose." append ]
  47     if print ;
  48
  49 ! The following two words are mutually recursive,
  50 ! providing the repl loop of the game
  51 : repeat ( vector -- )
  52     dup report obtain-word apply-word dup update-commands check-status  ;
  53 : check-status ( object -- )
  54     dup done?
  55         [ end-game ]
  56         [ dup quit? [ quit-game ] [ repeat ] if ]
  57     if ;
  58 : build-quad ( -- array ) 4 [ 10 random ] replicate >array ;
  59 : 24-able? ( vector -- t/f ) [ makes-24? ] with-datastack first ;
  60 : 24-able ( -- vector ) build-quad dup 24-able? [ drop build-quad ] unless ;
  61 : set-commands ( -- ) { + - * / rot swap q } commands set ;
  62 : play-game ( -- ) set-commands 24-able repeat ;
  63 MAIN: play-game