Countdown

This post is based on chapter 9 of https://www.cambridge.org/gb/academic/subjects/computer-science/programming-languages-and-applied-logic/programming-haskell-2nd-edition?format=PB.

The game of countdown is to combine a list of integers using common operations to make a target.

The allowed operations are +, -, * and /, with the restrictions that the result of a subtraction (even as an intermediate value) must not be negative, and the result of / must be an integer.

Graham Hutton tackles the problem by generating all the permutations from the list, then all the trees from the permutations, then all the operations from the nodes of the tree.

If I stare at this solution for long enough, I can see that it works, but I do not find it intuitive. In this program, I tried an alternative approach of taking all the ways of making an expression from two items in the list and combining them with the remainder. My compiled program ran in .06 seconds, which while slower than Hutton, is not embarassing.

The first two sections (defining operations and expressions) are taken almost directly from Hutton, while my own work starts at the comment ‘combinatorial functions’.

Hutton’s example is to generate 765 from [1,3,7,10,25,50]. This has 780 solutions, which Hutton reduced to 49 by avoiding redundant operations. This still leaves scope for reduction: Huttons solutions include

((((50+3=53)+7=60)+25=85)(10-1=9)=765) ((((50+7=57)+3=60)+25=85)(10-1=9)=765)
(((50+(7+3=10)=60)+25=85)(10-1=9)=765) ((((50+3=53)+25=78)+7=85)(10-1=9)=765)
((((50+25=75)+3=78)+7=85)(10-1=9)=765) (((50+(25+3=28)=78)+7=85)(10-1=9)=765)
(((50+3=53)+(25+7=32)=85)(10-1=9)=765) ((((50+7=57)+25=82)+3=85)(10-1=9)=765)
((((50+25=75)+7=82)+3=85)(10-1=9)=765) (((50+(25+7=32)=82)+3=85)(10-1=9)=765)
(((50+7=57)+(25+3=28)=85)(10-1=9)=765) (((50+25=75)+(7+3=10)=85)(10-1=9)=765)
((50+((25+3=28)+7=35)=85)(10-1=9)=765) ((50+((25+7=32)+3=35)=85)(10-1=9)=765)
((50+(25+(7+3=10)=35)=85)*(10-1=9)=765)

which are obviously equivalent.

Unnesting operations further reduced it to 11 solutions.

import System.Environment
import Data.List (partition,nub,sortBy)
import Data.Maybe (isJust)
import qualified Data.IntMap.Strict as M
import Control.Monad (filterM)

data Op = Add | Sub | Mul | Div 

ops = [Add,Sub,Mul,Div]

instance Show Op where
  show Add = "+"
  show Sub = "-"
  show Mul = "*"
  show Div = "/"

app::Op->(Int->Int->Int)
app Add = (+)
app Sub = (-)
app Mul = (*)
app Div = div

-- evaluate a binary operation, rejecting invalid or redundant cases
apply::Op->Maybe Int->Maybe Int->Maybe Int
apply op mi mj = case (op,mi,mj) of
  (Add, (Just i), (Just j)) | ((i==0) ||(j==0) || (i<j))          -> Nothing
  (Sub, (Just i), (Just j)) | (i<=j)                              -> Nothing
  (Mul, (Just i), (Just j)) | ((i==1) ||(j==1) || (i<j))          -> Nothing
  (Div, (Just i), (Just j)) | ((j<=1) || (i<j) || (mod i j /= 0)) -> Nothing
  _ -> pure (app op) <*> mi <*> mj
  
data Expr = Const Int | E Op Expr Expr (Maybe Int)  

instance Show Expr where
  show (Const x) = show x
  show (E op x y val) = concat ["(",(show x),(show op),(show y),"=",(drop 5 $ show val),")"]
 
eval::Expr->Maybe Int
eval (Const i) = Just i
eval (E _ _ _ val) = val

makeExps::(Expr->Expr->[Expr])
makeExps x y = 
   let x' = eval x
       y'= eval y in 
   if (x'>=y') then [E op x y (apply op x' y') | op<-ops] 
               else [E op y x (apply op y' x') | op<-ops] 

check::Int->Expr->Bool
check target exp = case (eval exp) of
  Just i -> i == target
  _      -> False 

-- combinatorial functions
-- non-trivial masks: each generated partition must be non-empty to ensure recursion progresses
-- 2 and 1 are special cases at call site in expressions
-- don't need reciprocal masks: TTF will generate the same partition as FFT
masks::Int->[[Bool]]
masks 1 = [[True]]  
masks 2 = [[True,True],[False,True]]
masks n = filter (any (==False)) [x : y | x<-[True,False], y<-masks (n-1)]

-- memoised; hardcoded max length 6
masksM::Int->[[Bool]]
masksM i = let m = M.fromAscList $ map (\x->(x,masks x)) [1..6]
  in (M.!) m i

partitions::[a]->[([a],[a])]
partitions xs = 
  map (\(x,y)->((map fst x,map fst y))) $ 
  map (partition (\x->(snd x)==True)) $ 
  map (zip xs) $  
  masksM (length xs) 

powerset::[a]->[[a]]
powerset xs = filterM (\x->[True,False]) xs 

-- all the expressions that use all the numbers in the partition
expressions::[Expr]->[Expr]
expressions [] = []
expressions (a:[]) = [a]
expressions (a:b:[]) = a:b:makeExps a b
expressions xs =  
  concat $ 
  map (\(a,b) -> concat [makeExps x y | x<-a,y<-b]) $ -- all the expressions combining the partitions
  map (\(a,b)->(expressions a,expressions b)) $       -- all the expressions from each partition 
  partitions xs                                       -- nontrivial ways to split the list 

solutions::Int->[Int]->[Expr]
solutions target xs = 
  filter (check target) $ 
  concat $ 
  map expressions $ 
  powerset $ 
  map Const xs


data Expr' = Const' Int | Sum' [Expr'] |  Prod [Expr'] |  Diff Expr' Expr' |  Ratio Expr' Expr' 

instance Show Expr' where
  show (Const' i) = concat [(show i)," "]
  show (Sum' (xs:[])) = show xs
  show (Sum' xs) = concat ["(Sum [",(concat (map show xs)),"])"]
  show (Prod (xs:[])) = show xs
  show (Prod xs) = concat ["(Prod [",(concat (map show xs)),"])"]
  show (Diff x y) = concat ["(",(show x), "-", (show y),")"]
  show (Ratio x y) = concat ["(",(show x), "/", (show y),")"]

-- sort the arguments of Sum or Prod - the ordering only needs to be consistent
srt::[Expr']->[Expr']
srt xs =  sortBy (\x y -> compare (show x) (show y)) xs 

-- combine expressions to a Sum' 
(.+)::Expr'->Expr'->Expr'
(.+) (Sum' xs) (Sum' ys) = Sum' $ srt (xs ++ ys)
(.+) x (Sum' ys) = Sum' $ srt (x:ys)
(.+) (Sum' xs) y = Sum' $ srt (y:xs)
(.+) x y = Sum' $ srt [x,y]

-- combine expressions to a Prod 
(.*)::Expr'->Expr'->Expr'
(.*) (Prod xs) (Prod ys) = Prod $ srt (xs ++ ys)
(.*) x (Prod ys) = Prod $ srt (x:ys)
(.*) (Prod xs) y = Prod $ srt (y:xs)
(.*) x y = Prod $ srt  [x,y]

simplify::Expr->Expr'
simplify (Const i) = Sum' [Const' i]
simplify (E Add x y _) = (.+) (simplify x) (simplify y)
simplify (E Mul x y _) = (.*) (simplify x) (simplify y)

simplify (E Sub x y _) =
  let x' = simplify x
      y' = simplify y
  in case (x',y') of
    (Diff xs xs',Diff ys ys') -> Diff (xs .+ ys') (xs' .+ ys)
    (Sum' xs,Diff ys ys') -> Diff ((Sum' xs) .+ (Sum' [ys])) ys' 
    (Diff xs xs',Sum' ys) -> Diff  xs (xs' .+ (Sum' ys)) 
    _ -> Diff x' y'

simplify (E Div x y _) =
  let x' = simplify x
      y' = simplify y
  in case (x',y') of
    (Ratio xs xs',Ratio ys ys') -> Ratio (xs .* ys') (xs' .* ys)
    (Sum' xs,Diff ys ys') -> Ratio ((Prod xs) .* (Prod [ys])) ys' 
    (Diff xs xs',Sum' ys) -> Ratio  xs (xs' .* (Prod ys)) 
    _ -> Ratio x' y'





main::IO ()
main = do
  args<-getArgs
  let ns = read $ args!!0
  let target = read $ args!!1
  mapM_ print $ nub $ map (show.simplify) $ solutions target ns

:main "[1,3,7,10,25,50]" "765"
"(Sum [(Prod [(Sum [(Prod [(Sum [1 7 ])3 ])50 ])10 ])25 ])"
"((Prod [(Sum [(Prod [(7 -1 )25 ])3 ])50 ])/10 )"
"(Prod [(25 -10 )(Sum [1 50 ])])"
"(Prod [((Sum [10 25 ])/7 )(Sum [1 50 ])3 ])"
"(Prod [((Prod [10 7 ])-25 )((Sum [1 50 ])/3 )])"
"(Prod [(25 -(Sum [3 7 ]))(Sum [1 50 ])])"
"(Prod [((Prod [(Sum [10 25 ])3 ])/7 )(Sum [1 50 ])])"
"(Prod [((Prod [(7 -3 )10 ])-25 )(Sum [1 50 ])])"
"(Sum [(25 -1 )(Prod [(Sum [10 3 ])(Sum [50 7 ])])])"
"(Prod [(10 -1 )(Sum [25 3 50 7 ])])"
"(Prod [(50 /10 )(Sum [(Prod [(7 -1 )25 ])3 ])])"

Further work:
memoise the generation of partitions and expressions.
improve the output format

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out /  Change )

Google photo

You are commenting using your Google account. Log Out /  Change )

Twitter picture

You are commenting using your Twitter account. Log Out /  Change )

Facebook photo

You are commenting using your Facebook account. Log Out /  Change )

Connecting to %s

%d bloggers like this: