24 game/Solve
import Data.List
import Data.Ratio
import Control.Monad
data Expr = Constant Rational |
Expr :+ Expr | Expr :- Expr |
Expr :* Expr | Expr :/ Expr
deriving (Eq)
data Result = Result {value :: Rational, lastOp :: String, lastValues :: [Rational]}
ops = [((:+), "+"), ((:-), "-"), ((:*), "*"), ((:/), "/")]
instance Show Expr where
show (Constant x) = show $ numerator x
show (a :+ b) = strexp "+" a b
show (a :- b) = strexp "-" a b
show (a :* b) = strexp "*" a b
show (a :/ b) = strexp "/" a b
strexp :: String -> Expr -> Expr -> String
strexp op a b = "(" ++ show a ++ " " ++ op ++ " " ++ show b ++ ")"
templates :: [[Expr] -> Expr]
templates = do
(op1, ch1) <- ops
(op2, ch2) <- ops
(op3, ch3) <- ops
let t1 = \[a, b, c, d] -> ((a `op1` b) `op2` c) `op3` d
let t2 = \[a, b, c, d] -> (a `op1` b) `op2` (c `op3` d)
let t3 = \[a, b, c, d] -> (a `op1` (b `op2` c)) `op3` d
let t4 = \[a, b, c, d] -> a `op1` ((b `op2` c) `op3` d)
let t5 = \[a, b, c, d] -> a `op1` (b `op2` (c `op3` d))
case (ch1, ch2, ch3) of
("+", "+", "+") -> [t1]
("*", "*", "*") -> [t1]
("+", "+", _ ) -> [t1,t2,t4]
( _ , "+", "+") -> [t1,t3,t4]
("*", "*", _ ) -> [t1,t2,t4]
( _ , "*", "*") -> [t1,t3,t4]
otherwise -> [t1,t2,t3,t4,t5]
isSorted :: (Ord a) => [a] -> Bool
isSorted [] = True
isSorted [x] = True
isSorted (x:y:xs) = x <= y && isSorted (y:xs)
eval :: Expr -> Maybe Result
eval (Constant c) = Just Result{value=c, lastOp="", lastValues=[c]}
eval (a :+ b) = do
Result{value=va, lastOp=opa, lastValues=lva} <- eval a
let lva' = if opa == "+" then lva else [va]
Result{value=vb, lastOp=opb, lastValues=lvb} <- eval b
let lvb' = if opb == "+" then lvb else [vb]
let lv = lva' ++ lvb'
guard $ isSorted lv
return Result{value=va + vb, lastOp="+", lastValues=lv}
eval (a :- b) = do
Result{value=va} <- eval a
Result{value=vb} <- eval b
let v = va - vb
return Result{value=v, lastOp="", lastValues=[v]}
eval (a :* b) = do
Result{value=va, lastOp=opa, lastValues=lva} <- eval a
let lva' = if opa == "*" then lva else [va]
Result{value=vb, lastOp=opb, lastValues=lvb} <- eval b
let lvb' = if opb == "*" then lvb else [vb]
let lv = lva' ++ lvb'
guard $ isSorted lv
return Result{value=va * vb, lastOp="*", lastValues=lv}
eval (a :/ b) = do
Result{value=va} <- eval a
Result{value=vb} <- eval b
guard $ vb /= 0
let v = va / vb
return Result{value=v, lastOp="", lastValues=[v]}
solve :: Rational -> [Rational] -> [Expr]
solve target r4 = filter (maybe False (\r -> value r == target) . eval) $
liftM2 ($) templates $
nub $ permutations $ map Constant r4
main = mapM_ (\x -> putStrLn $ show x ++ " = 24") . solve 24 $ [1,2,3,4]
((1 + 3) * (2 + 4)) = 24
(4 * ((1 + 2) + 3)) = 24
(((1 * 2) * 3) * 4) = 24
(((2 * 3) * 4) / 1) = 24
((2 * 3) * (4 / 1)) = 24
(3 * ((2 * 4) / 1)) = 24
(4 * ((2 * 3) / 1)) = 24
(2 * ((3 * 4) / 1)) = 24
((2 * (3 / 1)) * 4) = 24
(2 * ((3 / 1) * 4)) = 24
((2 * 3) / (1 / 4)) = 24
((2 * 4) / (1 / 3)) = 24
((3 * 4) / (1 / 2)) = 24
(3 * (2 / (1 / 4))) = 24
(2 * (3 / (1 / 4))) = 24
(4 * (2 / (1 / 3))) = 24
(2 * (4 / (1 / 3))) = 24
(4 * (3 / (1 / 2))) = 24
(3 * (4 / (1 / 2))) = 24
(((2 / 1) * 3) * 4) = 24
(2 / (1 / (3 * 4))) = 24
(3 / (1 / (2 * 4))) = 24
(4 / (1 / (2 * 3))) = 24
(2 / ((1 / 3) / 4)) = 24
(3 / ((1 / 2) / 4)) = 24
(4 / ((1 / 2) / 3)) = 24
(2 / ((1 / 4) / 3)) = 24
(4 / ((1 / 3) / 2)) = 24
(3 / ((1 / 4) / 2)) = 24
