extra/24-game/24-game.factor

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