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             some-rots do-something
  19             some-rots do-something
  20             maybe-swap do-something
  21             24 =
  22         ]
  23         [ 4drop ]
  24     if-amb ;
  25 : q ( -- obj ) "quit" ;
  26 : show-commands ( -- ) "Commands: " write commands get unparse print ;
  27 : report ( vector -- ) unparse print show-commands ;
  28 : give-help ( -- ) "Command not found..." print show-commands ;
  29 : find-word ( string choices -- word ) [ name>> = ] with find nip ;
  30 : obtain-word ( -- word )
  31     readln commands get find-word dup
  32     [ drop give-help obtain-word ] unless ;
  33 : done? ( vector -- t/f ) 1 swap length = ;
  34 : victory? ( vector -- t/f ) { 24 } = ;
  35 : apply-word ( vector word -- array ) 1quotation with-datastack >array ;
  36 : update-commands ( vector -- )
  37     length 3 <
  38         [ commands [ \ rot swap remove ] change ]
  39         [ ]
  40     if ;
  41 DEFER: check-status
  42 : quit-game ( vector -- ) drop "you're a quitter" print ;
  43 : quit? ( vector -- t/f ) peek "quit" = ;
  44 : end-game ( vector -- )
  45     dup victory?
  46         [ drop "You WON!" ]
  47         [ pop number>string " is not 24... You lose." append ]
  48     if print ;
  49
  50 ! The following two words are mutually recursive,
  51 ! providing the repl loop of the game
  52 : repeat ( vector -- )
  53     dup report obtain-word apply-word dup update-commands check-status  ;
  54 : check-status ( object -- )
  55     dup done?
  56         [ end-game ]
  57         [ dup quit? [ quit-game ] [ repeat ] if ]
  58     if ;
  59 : build-quad ( -- array ) 4 [ 10 random ] replicate >array ;
  60 : 24-able? ( quad -- t/f ) [ makes-24? ] with-datastack first ;
  61 : 24-able ( -- vector ) build-quad dup 24-able? [ drop build-quad ] unless ;
  62 : set-commands ( -- ) { + - * / rot swap q } commands set ;
  63 : play-game ( -- ) set-commands 24-able repeat ;
  64 MAIN: play-game