arithmetic.hs

module Arithmetic where

import Data.Set hiding (map)

solve target inputs = [e | e <- exprs inputs, Just target == eval e]

-- Expressions
data Expr = Num Rational | Op Op Expr Expr deriving (Eq, Ord)
instance Show Expr where
    show (Num n) = show n
    show (Op o x y) = "(" ++ show x ++ " " ++ o ++ " " ++ show y ++ ")"

eval :: Expr -> Maybe Rational
eval (Num n) = Just n
eval (Op o a b) = do x <- eval a; y <- eval b; op o x y

type Op = String

ops :: [Op]
ops = map (:[]) "+-/*"

op :: Op -> Rational -> Rational -> Maybe Rational
op "+" x y = Just (x+y)
op "-" x y = Just (x-y)
op "*" x y = Just (x*y)
op "/" x 0 = Nothing
op "/" x y = Just (x/y)

-- Generating expressions
type State = [Expr]

exprs :: [Rational] -> [Expr]
exprs inputs = [e | [e] <- toList (fix step (singleton start))]
    where start :: State
          start = map Num inputs

step :: Set State -> Set State
step set = set `union` fromList added
    where added = do state <- toList set
                     gen state

gen :: State -> [State]
gen es = do (x,es) <- pick es
            (y,es) <- pick es
            o <- ops
            return (Op o x y : es)

pick :: [a] -> [(a,[a])]
pick [] = []
pick (x:xs) = (x,xs) : map (\(e,es) -> (e,x:es)) (pick xs)

-- Iterates a function till it reaches a fixed-point.
fix :: Eq a => (a -> a) -> a -> a
fix f init = if init == next then init else fix f next
    where next = f init