75 lines
1.7 KiB
Factor
75 lines
1.7 KiB
Factor
! Copyright © 2008 Reginald Keith Ford II
|
|
! 24, the Factor game!
|
|
USING: accessors backtrack combinators continuations formatting fry io
|
|
kernel math prettyprint quotations random sequences shuffle ;
|
|
IN: 24-game
|
|
|
|
: nop ( -- ) ;
|
|
|
|
: ?/ ( a b -- c ) [ drop 1/0. ] [ / ] if-zero ;
|
|
|
|
: do-operation ( a b -- c )
|
|
{ + - * ?/ } amb-execute ;
|
|
|
|
: permute-2 ( a b -- a b )
|
|
{ nop swap } amb-execute ;
|
|
|
|
: permute-3 ( a b c -- a b c )
|
|
{ nop rot -rot swap spin swapd } amb-execute ;
|
|
|
|
: makes-24? ( a b c d -- ? )
|
|
[
|
|
permute-3 do-operation
|
|
permute-3 do-operation
|
|
permute-2 do-operation
|
|
24 =
|
|
] [ 4drop ] if-amb ;
|
|
|
|
: random-4 ( -- array )
|
|
4 [ 10 random ] replicate ;
|
|
|
|
: make-24 ( -- array )
|
|
f [ dup first4 makes-24? ] [ drop random-4 ] do until ;
|
|
|
|
: q ( -- obj ) "quit" ;
|
|
|
|
CONSTANT: (operators) { + - * / rot swap q }
|
|
|
|
: operators ( array -- operators )
|
|
length 3 < [ \ rot (operators) remove ] [ (operators) ] if ;
|
|
|
|
: find-operator ( operators string -- word/f )
|
|
'[ name>> _ = ] find nip ;
|
|
|
|
: get-operator ( operators -- word )
|
|
dup "Operators: %u\n" printf flush
|
|
dup readln find-operator [ ] [
|
|
"Operator not found..." print get-operator
|
|
] ?if ;
|
|
|
|
: try-operator ( array -- array )
|
|
[ pprint nl ]
|
|
[ dup operators get-operator 1quotation with-datastack ]
|
|
bi ;
|
|
|
|
: end-game ( array -- )
|
|
first dup 24 = [
|
|
drop "You WON!"
|
|
] [
|
|
"%d is not 24... You lose." sprintf
|
|
] if print ;
|
|
|
|
: quit-game ( array -- )
|
|
drop "you're a quitter" print ;
|
|
|
|
: play-24 ( array -- )
|
|
{
|
|
{ [ dup length 1 = ] [ end-game ] }
|
|
{ [ dup last "quit" = ] [ quit-game ] }
|
|
[ try-operator play-24 ]
|
|
} cond ;
|
|
|
|
: 24-game ( -- ) make-24 play-24 ;
|
|
|
|
MAIN: 24-game
|