[ create a new paste ] login | about

Link: http://codepad.org/VNauTAam    [ raw code | output | fork ]

jdressel - Haskell, pasted on Aug 21:
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])
            ]


Output:
1
2
Working nub: [(((2+9)+9)/2)]
Broken nub: [(((2+9)+9)/2),((2+(9+9))/2)]


Create a new paste based on this one


Comments: