Frege version of the Countdown program

Countdown.fr

module Countdown where

--Expressions
-----------
native      getCPUTime java.lang.System.currentTimeMillis :: () -> IO Long
pure native formatLocale java.lang.String.format :: Maybe JLocale -> String -> Float -> String
data JLocale = pure native java.util.Locale


format s f = formatLocale Nothing s f

read :: String -> Int
read x = case x.int of
   Right y -> y
   _       -> 0

readNumbers :: String -> [Int]
readNumbers = map read . words


data Op                       =  Add | Sub | Mul | Div

valid                         :: Op -> Int -> Int -> Bool
valid Add _ _                 =  True
valid Sub x y                 =  x > y
valid Mul _ _                 =  True
valid Div x y                 =  x `mod` y == 0

apply_                         :: Op -> Int -> Int -> Int
apply_ Add x y                 =  x + y
apply_ Sub x y                 =  x - y
apply_ Mul x y                 =  x * y
apply_ Div x y                 =  x `div` y

data Expr                     =  Val Int | App Op Expr Expr

values                        :: Expr -> [Int]
values (Val n)                =  [n]
values (App _ l r)            =  values l ++ values r

eval                          :: Expr -> [Int]
eval (Val n)                  =  [n | n > 0]
eval (App o l r)              =  [apply_ o x y | x <- eval l
                                              , y <- eval r
                                              , valid o x y]

--Combinatorial functions
-----------------------

subs                          :: [a] -> [[a]]
subs []                       =  [[]]
subs (x:xs)                   =  yss ++ map (x:) yss
                                 where yss = subs xs

interleave                    :: a -> [a] -> [[a]]
interleave x []               =  [[x]]
interleave x (y:ys)           =  (x:y:ys) : map (y:) (interleave x ys)

perms                         :: [a] -> [[a]]
perms []                      =  [[]]
perms (x:xs)                  =  concat (map (interleave x) (perms xs))

choices                       :: [a] -> [[a]]
choices xs                    =  [zs | ys <- subs xs, zs <- perms ys]

--Formalising the problem
-----------------------

solution                      :: Expr -> [Int] -> Int -> Bool
solution e ns n               =  elem (values e) (choices ns) && eval e == [n]

--Brute force solution
--------------------

split                         :: [a] -> [([a],[a])]
split []                      = []
split [_]                     = []
split (x:xs)                  = ([x], xs) : [(x: ls, rs) | (ls, rs) <- split xs]

exprs                         :: [Int] -> [Expr]
exprs []                      =  []
exprs [n]                     =  [Val n]
exprs ns                      =  [e | (ls,rs) <- split ns
                                    , l       <- exprs ls
                                    , r       <- exprs rs
                                    , e       <- combine l r]

combine                       :: Expr -> Expr -> [Expr]
combine l r                   =  [App o l r | o <- ops]

ops                           :: [Op]
ops                           =  [Add,Sub,Mul,Div]

solutions                     :: [Int] -> Int -> [Expr]
solutions ns n                =  [e | ns' <- choices ns
                                    , e   <- exprs ns'
                                    , eval e == [n]]

--Combining generation and evaluation
-----------------------------------

type Result'                   =  (Expr,Int)

results                       :: [Int] -> [Result']
results []                    =  []
results [n]                   =  [(Val n,n) | n > 0]
results ns                    =  [res | (ls,rs) <- split ns
                                      , lx      <- results ls
                                      , ry      <- results rs
                                      , res     <- combine' lx ry]

combine'                      :: Result' -> Result' -> [Result']
combine' (l,x) (r,y)          =  [(App o l r, apply_ o x y) | o <- ops
                                                           , valid o x y]

solutions'                    :: [Int] -> Int -> [Expr]
solutions' ns n               =  [e | ns'   <- choices ns
                                    , (e,m) <- results ns'
                                    , m == n]

--Exploiting numeric properties
-----------------------------

valid'                        :: Op -> Int -> Int -> Bool
valid' Add x y                =  x <= y
valid' Sub x y                =  x > y
valid' Mul x y                =  x /= 1 && y /= 1 && x <= y
valid' Div x y                =  y /= 1 && x `mod` y == 0

results'                      :: [Int] -> [Result']
results' []                   =  []
results' [n]                  =  [(Val n,n) | n > 0]
results' ns                   =  [res | (ls,rs) <- split ns
                                      , lx      <- results' ls
                                      , ry      <- results' rs
                                      , res     <- combine'' lx ry]

combine''                     :: Result' -> Result' -> [Result']
combine'' (l,x) (r,y)         =  [(App o l r, apply_ o x y) | o <- ops
                                                           , valid' o x y]

solutions''                   :: [Int] -> Int -> [Expr]
solutions'' ns n              =  [e | ns'   <- choices ns
                                    , (e,m) <- results' ns'
                                    , m == n]

--Interactive version for testing
-------------------------------

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


instance Show Expr where
   show (Val n)               =  show n
   show (App o l r)           =  bracket l ++ show o ++ bracket r
                                 where
                                    bracket (Val n) = show n
                                    bracket e       = "(" ++ show e ++ ")"

showtime                      :: Long -> String
showtime t                    =  " in " ++ show t ++ " ms."


display_                       :: [Expr] -> IO ()
display_ es                    =  do
                                    t0 <- getCPUTime ()
                                    if null es then
                                       do
                                          t1 <- getCPUTime ()
                                          putStr "\nThere are no solutions, verified in "
                                          putStrLn (showtime (t1 - t0))
                                    else
                                       do
                                          t1 <- getCPUTime ()
                                          putStr "\nOne possible solution is "
                                          putStr (show (head es))
                                          putStr ", found in "
                                          putStrLn (showtime (t1 - t0))
                                          putStr "\nPress return to continue searching..."
                                          stdout.flush
                                          getLine
                                          putStrLn ""
                                          t2 <- getCPUTime ()
                                          if null (tail es) then
                                             putStrLn "There are no more solutions"
                                           else
                                             do sequence [println e | e <- tail es]
                                                putStr "\nThere were "
                                                putStr (show (length es))
                                                putStr " solutions in total, found in "
                                                t3 <- getCPUTime ()
                                                putStrLn (showtime ((t1 - t0) + (t3 - t2)))
                                    putStrLn ".\n"


main                          :: IO ()
main                          =  do 
                                    putStrLn "\nCOUNTDOWN NUMBERS GAME SOLVER"
                                    putStrLn "-----------------------------\n"
                                    ns <- stdout.print "Enter the given numbers: " >> stdout.flush >> getLine
                                    n  <- stdout.print "Enter the target number: " >> stdout.flush >> getLine
                                    display_ (solutions'' (readNumbers ns) (read n))