module Main where
import qualified Data.List as L
-- Start Domain-Specific-Language (DSL) for expression-creation
-- and evaluation.
-- Algebraic type wrapping to do symbol manipulation
data Operation = Add | Subtract | Multiply | Divide
deriving Eq
-- Expressions are naturally binary tree structures
data Expression = Leaf (Maybe Integer) | Branch Expression Operation Expression
-- Expression equivalence
-- To do this properly would require a better data representation to
-- make the separation between commutative and noncommutative binary
-- operators cleaner.
-- This basic filter just cuts the most frequent duplicates to thin
-- the list to a manageable size.
instance Eq Expression where
(==) (Leaf a) (Leaf b) = a == b
(==) (Leaf _) (Branch _ _ _) = False
(==) (Branch _ _ _) (Leaf _) = False
-- Screw third layer. Also screw more complex checking.
-- Handle second layer commutative equivalence explicitly
(==) (Branch (Branch e1 Add e2) Add e3) (Branch (Branch e4 Add e5) Add e6) =
(e1 == e4 && e2 == e5 && e3 == e6) || (e1 == e6 && e2 == e5 && e3 == e4) ||
(e1 == e4 && e2 == e6 && e3 == e5) || (e1 == e5 && e2 == e6 && e3 == e4) ||
(e1 == e5 && e2 == e4 && e3 == e6) || (e1 == e6 && e2 == e4 && e3 == e5)
(==) (Branch e1 Add (Branch e2 Add e3)) (Branch e4 Add (Branch e5 Add e6)) =
(e1 == e4 && e2 == e5 && e3 == e6) || (e1 == e6 && e2 == e5 && e3 == e4) ||
(e1 == e4 && e2 == e6 && e3 == e5) || (e1 == e5 && e2 == e6 && e3 == e4) ||
(e1 == e5 && e2 == e4 && e3 == e6) || (e1 == e6 && e2 == e4 && e3 == e5)
(==) (Branch (Branch e1 Add e2) Add e3) (Branch e4 Add (Branch e5 Add e6)) =
(e1 == e4 && e2 == e5 && e3 == e6) || (e1 == e6 && e2 == e5 && e3 == e4) ||
(e1 == e4 && e2 == e6 && e3 == e5) || (e1 == e5 && e2 == e6 && e3 == e4) ||
(e1 == e5 && e2 == e4 && e3 == e6) || (e1 == e6 && e2 == e4 && e3 == e5)
(==) (Branch (Branch e1 Multiply e2) Multiply e3)
(Branch (Branch e4 Multiply e5) Multiply e6) =
(e1 == e4 && e2 == e5 && e3 == e6) || (e1 == e6 && e2 == e5 && e3 == e4) ||
(e1 == e4 && e2 == e6 && e3 == e5) || (e1 == e5 && e2 == e6 && e3 == e4) ||
(e1 == e5 && e2 == e4 && e3 == e6) || (e1 == e6 && e2 == e4 && e3 == e5)
(==) (Branch e1 Multiply (Branch e2 Multiply e3))
(Branch e4 Multiply (Branch e5 Multiply e6)) =
(e1 == e4 && e2 == e5 && e3 == e6) || (e1 == e6 && e2 == e5 && e3 == e4) ||
(e1 == e4 && e2 == e6 && e3 == e5) || (e1 == e5 && e2 == e6 && e3 == e4) ||
(e1 == e5 && e2 == e4 && e3 == e6) || (e1 == e6 && e2 == e4 && e3 == e5)
(==) (Branch (Branch e1 Multiply e2) Multiply e3)
(Branch e4 Multiply (Branch e5 Multiply e6)) =
(e1 == e4 && e2 == e5 && e3 == e6) || (e1 == e6 && e2 == e5 && e3 == e4) ||
(e1 == e4 && e2 == e6 && e3 == e5) || (e1 == e5 && e2 == e6 && e3 == e4) ||
(e1 == e5 && e2 == e4 && e3 == e6) || (e1 == e6 && e2 == e4 && e3 == e5)
-- Handle first layer commutative equivalence explicitly
(==) (Branch e1 Add e2) (Branch e3 Add e4) =
(e1 == e3 && e2 == e4) || (e1 == e4 && e2 == e3)
(==) (Branch e1 Multiply e2) (Branch e3 Multiply e4) =
(e1 == e3 && e2 == e4) || (e1 == e4 && e2 == e3)
-- Noncommutative general case
(==) (Branch e1 a e2) (Branch e3 b e4) = a == b && (e1 == e3) && (e2 == e4)
-- Print convenience later
instance Show Operation where
show Add = "+"
show Subtract = "-"
show Multiply = "*"
show Divide = "/"
instance Show Expression where
show (Leaf (Just a)) = show a
show (Branch e1 o e2) = "("++show e1++show o++show e2++")"
show _ = "()"
-- Eval for symbol expression simplification retaining only integer results
-- Simplifies an expression either to a Leaf or a Nothing, depending on whether
-- the operations stayed in ring of integers or not.
eval :: Expression -> Expression
eval (Leaf a) = Leaf a
eval (Branch (Leaf Nothing) _ _) = Leaf Nothing
eval (Branch _ _ (Leaf Nothing)) = Leaf Nothing
eval (Branch (Leaf (Just a)) o (Leaf (Just b))) = case o of
Add -> Leaf $ Just $ (+) a b
Subtract -> Leaf $ Just $ (-) a b
Multiply -> Leaf $ Just $ (*) a b
Divide -> if b == 0 then Leaf Nothing else
case quotRem a b of
(n,0) -> Leaf $ Just n
(_,_) -> Leaf Nothing
eval (Branch e1 o e2) = eval $ Branch (eval e1) o (eval e2)
-- Redefine nub
-- Found a cute bug where the normal nub does not in fact nub out
-- all possibilities reliably. However this redefinition does.
-- Go figure.
nub :: (Eq a) => [a] -> [a]
nub = L.nubBy (==)
-- Define simple list permutations
permutations :: (Eq a) => [a] -> [[a]]
permutations [] = [[]]
permutations xs = [x:ps | x <- xs, ps <- permutations (xs L.\\ [x])]
-- Define total permutations of three possible operations
operations :: [[Operation]]
operations = [[x,y,z] | x <- p, y <- p, z <- p]
where
p = [Add, Subtract, Multiply, Divide]
-- Zip up list of elements and operations into all parenthized expressions
-- Deliberately only works for 4 numbers currently. General solution not
-- attempted yet.
express :: [Integer] -> [Operation] -> [Expression]
express [i1,i2,i3,i4] [o1,o2,o3] = [e1,e2,e3,e4,e5]
where
l i = Leaf (Just i)
b l1 o l2 = Branch l1 o l2
e1 = b (b (b (l i1) o1 (l i2)) o2 (l i3)) o3 (l i4)
e2 = b (b (l i1) o1 (b (l i2) o2 (l i3))) o3 (l i4)
e3 = b (b (l i1) o1 (l i2)) o2 (b (l i3) o3 (l i4))
e4 = b (l i1) o1 (b (b (l i2) o2 (l i3)) o3 (l i4))
e5 = b (l i1) o1 (b (l i2) o2 (b (l i3) o3 (l i4)))
express _ _ = error "Unsupported expression."
-- Take a list of integers and form all possible expressions out of it
makeExpressions :: [Integer] -> [Expression]
makeExpressions l = concat [express i o | i <- permutations l, o <- operations]
-- Filter list of expressions keeping only ones that evaluate to a specific Leaf
keepLeaf :: Integer -> [Expression] -> [Expression]
keepLeaf i = filter ((Leaf (Just i) == ) . eval)
-- Find all solutions for a particular 4 numbers
solve :: Integer -> [Integer] -> [Expression]
solve i = nub . keepLeaf i . concatMap makeExpressions . permutations
solveBroken :: Integer -> [Integer] -> [Expression]
solveBroken i = L.nub . keepLeaf i . concatMap makeExpressions . permutations
main = sequence_ $ map putStrLn cases
where
cases = ["Working nub: "++(show $ solve 10 [2,2,9,9])
,"Broken nub: "++(show $ solveBroken 10 [2,2,9,9])
]