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     [ "Operators: %u\n" printf flush ]
  47     [
  48         [ readln find-operator ]
  49         [ "Operator not found..." print get-operator ] ?unless
  50     ] bi ;
  51
  52 : try-operator ( array -- array )
  53     [ pprint nl ]
  54     [ dup operators get-operator 1quotation with-datastack ]
  55     bi ;
  56
  57 : end-game ( array -- )
  58     first dup 24 = [
  59         drop "You WON!"
  60     ] [
  61         "%d is not 24... You lose." sprintf
  62     ] if print ;
  63
  64 : quit-game ( array -- )
  65     drop "you're a quitter" print ;
  66
  67 : play-24 ( array -- )
  68     {
  69         { [ dup length 1 = ] [ end-game ] }
  70         { [ dup last "quit" = ] [ quit-game ] }
  71         [ try-operator play-24 ]
  72     } cond ;
  73
  74 : 24-game ( -- ) make-24 play-24 ;
  75
  76 MAIN: 24-game