extra/24-game/24-game.factor

   1 ! Copyright © 2008 Reginald Keith Ford II
   2 ! 24, the Factor game!
   3 USING: accessors backtrack combinators continuations formatting fry io
   4 kernel math prettyprint quotations random sequences shuffle ;
   5 IN: 24-game
   6
   7 : nop ( -- ) ;
   8
   9 : ?/ ( a b -- c ) [ drop 1/0. ] [ / ] if-zero ;
  10
  11 : do-operation ( a b -- c )
  12     { + - * ?/ } amb-execute ;
  13
  14 : permute-2 ( a b -- a b )
  15     { nop swap } amb-execute ;
  16
  17 : permute-3 ( a b c -- a b c )
  18     { nop rot -rot swap spin swapd } amb-execute ;
  19
  20 : makes-24? ( a b c d -- ? )
  21     [
  22         permute-3 do-operation
  23         permute-3 do-operation
  24         permute-2 do-operation
  25         24 =
  26     ] [ 4drop ] if-amb ;
  27
  28 : random-4 ( -- array )
  29     4 [ 10 random ] replicate ;
  30
  31 : make-24 ( -- array )
  32     f [ dup first4 makes-24? ] [ drop random-4 ] do until ;
  33
  34 : q ( -- obj ) "quit" ;
  35
  36 CONSTANT: (operators) { + - * / rot swap q }
  37
  38 : operators ( array -- operators )
  39     length 3 < [ \ rot (operators) remove ] [ (operators) ] if ;
  40
  41 : find-operator ( operators string -- word/f )
  42     '[ name>> _ = ] find nip ;
  43
  44 : get-operator ( operators -- word )
  45     dup "Operators: %u\n" printf flush
  46     dup readln find-operator [ ] [
  47         "Operator not found..." print get-operator
  48     ] ?if ;
  49
  50 : try-operator ( array -- array )
  51     [ pprint nl ]
  52     [ dup operators get-operator 1quotation with-datastack ]
  53     bi ;
  54
  55 : end-game ( array -- )
  56     first dup 24 = [
  57         drop "You WON!"
  58     ] [
  59         "%d is not 24... You lose." sprintf
  60     ] if print ;
  61
  62 : quit-game ( array -- )
  63     drop "you're a quitter" print ;
  64
  65 : play-24 ( array -- )
  66     {
  67         { [ dup length 1 = ] [ end-game ] }
  68         { [ dup last "quit" = ] [ quit-game ] }
  69         [ try-operator play-24 ]
  70     } cond ;
  71
  72 : 24-game ( -- ) make-24 play-24 ;
  73
  74 MAIN: 24-game