Utterly nerd sniped.

Raphael.hs

module Main where 

import Control.Monad
import Data.List
import Data.Function

-- Define a name - i.e. just a variable
data Name = MkName Char deriving (Eq, Show)

-- Define a context - a mapping from variabels to values
data Context = Ctx [(Name, Int)] deriving (Eq)

-- pretty print them...
instance Show Context where 
    show (Ctx ps) = "[" ++ (intercalate ", " $ map showPair ps) ++ "]" where 
        showPair (MkName c, i) = [c] ++ " -> " ++ (show i)

-- Get names given a list of values. 
mkNames :: [a] -> [Name]
mkNames l = take (length l) $ map MkName ['a'..]

-- Make a specific context. 
mkContext :: [Name] -> [Int] -> Context 
mkContext n v = Ctx $ zip n v 

-- Make all possible contexts from these values
mkContexts :: [Int] -> [Context]
mkContexts v = nub $ map (mkContext names) $ permutations v where 
    names = mkNames v

-- Define arithmetic expressions of the kind that we're allowed in countdown. 
data Expression = 
    Add Expression Expression | 
    Sub Expression Expression | 
    Mul Expression Expression | 
    Div Expression Expression | 
    Var Name
    deriving (Eq)

-- Define a representation, given a context, that returns variable names 
-- if a value cannot be found in the context. 
repr :: Expression -> Context -> String 
repr (Var (MkName n)) (Ctx c) = case lookup (MkName n) c of
    Just i -> show i
    Nothing -> [n]
repr (Add l r) c = "(" ++ (repr l c) ++ "+" ++ (repr r c) ++ ")" 
repr (Sub l r) c = "(" ++ (repr l c) ++ "-" ++ (repr r c) ++ ")" 
repr (Mul l r) c = "(" ++ (repr l c) ++ "*" ++ (repr r c) ++ ")" 
repr (Div l r) c = "(" ++ (repr l c) ++ "/" ++ (repr r c) ++ ")" 

-- Define a pretty printer using an empty context (always showing names)
instance Show Expression where 
    show e = repr e (Ctx [])

-- Define evaluation for an expression, given a context (assignment to variables) 
eval :: Expression -> Context -> Maybe Int
eval (Var v) (Ctx c) = lookup v c
eval (Add l r) c = liftM2 (+) (eval l c) (eval r c) 
eval (Sub l r) c = liftM2 (-) (eval l c) (eval r c) 
eval (Mul l r) c = liftM2 (*) (eval l c) (eval r c) 
eval (Div l r) c = lf ((eval l c), (eval r c)) >>= uncurry checkedDiv where
    lf (Just a, Just b) = Just (a, b)
    lf _ = Nothing
    checkedDiv i j = if j /= 0 && i `mod` j == 0 then Just (i `div` j) else Nothing

-- Expand a list of names into possible expressions involving the names. 
-- This is where the "meat" of the program is, and where we generate trees. 
-- Note, we make sure that we use each variable _once_, by creating a Var 
-- at the very root of the recursion, and not before. 
expand :: [Name] -> [Expression]
expand [] = undefined 
expand (n:[]) = [Var n]
expand (n:ns) = (expand ns) >>= (pairs (Var n)) where
    pairs :: Expression -> Expression -> [Expression]
    pairs v e = [Add v e, Mul v e, Sub v e, Sub e v, Div v e, Div e v]

-- Show a list of showables in a nicer way. 
prettyShow :: Show a => [a] -> String
prettyShow xs = "[\n  " ++ (intercalate "\n  " $ map show xs) ++ "\n]"

-- Given a set of possible assignments, and an expression, find out every possible
-- outcome of evaluating that expression, given those values. 
-- For utilities sake, group the result with the context + expression
tryExpression :: [Context] -> Expression -> [(String, Int)]
tryExpression cs e = cs >>= (groupEval e) where 
    groupEval :: Expression -> Context -> [(String, Int)]
    groupEval e c = case eval e c of 
        Just i -> [(repr e c, i)]
        Nothing -> []

-- Given a list of integers, find every possible expression, assignment, and result
findSolutions :: [Int] -> [(String, Int)]
findSolutions values = expressions >>= (tryExpression contexts) where 
    names = mkNames values
    contexts = mkContexts values
    expressions = expand names 

main :: IO () 
main = putStrLn $ prettyShow $ sortBy (compare `on` snd) $ findSolutions [3,3,8,8]