A Haskell program to solve http://www.bbc.co.uk/programmes/articles/5wkxjTtqRvq8Cyrrjxtk7tc/puzzle-for-today

puzzle-for-today.hs

import Control.Monad (replicateM)
import Control.Applicative ((<$>))
import Data.List (sortBy)
import Data.Maybe (listToMaybe)
import Data.Ord (comparing)

data Token = Plus | Minus | None deriving (Show, Eq)
data Fragment a = Add a | Sub a deriving Show

newtype Solution = Solution { getSolution :: [Token] }

-- Example from the website: 1 + 2 + 34 - 5 + 67 - 8 + 9
example :: Solution
example = Solution [ Plus
                   , Plus
                   , None
                   , Minus
                   , Plus
                   , None
                   , Minus
                   , Plus
                   ]

-- Pretty print the solution
instance Show Solution where
  show = ('1' :) . foldr f "" . flip zip [2..] . getSolution
    where
      f (None,  x) str = show x ++ str
      f (Plus,  x) str = " + " ++ show x ++ str
      f (Minus, x) str = " - " ++ show x ++ str

-- Evaluate a solution to a number
eval = uncurry apply . foldl f (Add 1, 0) . flip zip [2..] . getSolution
  where
    f (fr, acc) (None,  x) = (grow fr x , acc)
    f (fr, acc) (Plus,  x) = (Add x, apply fr acc) 
    f (fr, acc) (Minus, x) = (Sub x, apply fr acc)

    -- We use 'fragments' to keep track of the sign
    grow :: Num a => Fragment a -> a -> Fragment a
    grow (Add x) y = Add (x * 10 + y)
    grow (Sub x) y = Sub (x * 10 + y)
    
    apply :: Num a => Fragment a -> a -> a
    apply (Add x) = (+ x)
    apply (Sub x) = subtract x

-- The search space for this puzzle, with 3^8 elements
space n = Solution <$> replicateM n [Plus, Minus, None]

-- The number of + and -'s
cost :: Solution -> Int
cost = length . filter (/= None) . getSolution

-- Search for the best solution (if it exists)
search :: [Solution] -> Maybe Solution
search = listToMaybe . sortBy (comparing cost) . filter ((== 100) . eval)

-- Calculate for the numbers 1..9
main :: IO ()
main = print $ search $ space 8