Data commit

Task/24-game-Solve/Haskell/24-game-solve-1.hs

@@ -0,0 +1,50 @@
+import Data.List
+import Data.Ratio
+import Control.Monad
+import System.Environment (getArgs)
+
+data Expr = Constant Rational |
+    Expr :+ Expr | Expr :- Expr |
+    Expr :* Expr | Expr :/ Expr
+    deriving (Eq)
+
+ops = [(:+), (:-), (:*), (:/)]
+
+instance Show Expr where
+    show (Constant x) = show $ numerator x
+      -- In this program, we need only print integers.
+    show (a :+ b)     = strexp "+" a b
+    show (a :- b)     = strexp "-" a b
+    show (a :* b)     = strexp "*" a b
+    show (a :/ b)     = strexp "/" a b
+
+strexp :: String -> Expr -> Expr -> String
+strexp op a b = "(" ++ show a ++ " " ++ op ++ " " ++ show b ++ ")"
+
+templates :: [[Expr] -> Expr]
+templates = do
+    op1 <- ops
+    op2 <- ops
+    op3 <- ops
+    [\[a, b, c, d] -> op1 a $ op2 b $ op3 c d,
+     \[a, b, c, d] -> op1 (op2 a b) $ op3 c d,
+     \[a, b, c, d] -> op1 a $ op2 (op3 b c) d,
+     \[a, b, c, d] -> op1 (op2 a $ op3 b c) d,
+     \[a, b, c, d] -> op1 (op2 (op3 a b) c) d]
+
+eval :: Expr -> Maybe Rational
+eval (Constant c) = Just c
+eval (a :+ b)     = liftM2 (+) (eval a) (eval b)
+eval (a :- b)     = liftM2 (-) (eval a) (eval b)
+eval (a :* b)     = liftM2 (*) (eval a) (eval b)
+eval (a :/ b)     = do
+    denom <- eval b
+    guard $ denom /= 0
+    liftM (/ denom) $ eval a
+
+solve :: Rational -> [Rational] -> [Expr]
+solve target r4 = filter (maybe False (== target) . eval) $
+    liftM2 ($) templates $
+    nub $ permutations $ map Constant r4
+
+main = getArgs >>= mapM_ print . solve 24 . map (toEnum . read)

Task/24-game-Solve/Haskell/24-game-solve-2.hs

@@ -0,0 +1,42 @@
+import Control.Applicative
+import Data.List
+import Text.PrettyPrint
+
+
+data Expr = C Int | Op String Expr Expr
+
+toDoc (C     x  ) = int x
+toDoc (Op op x y) = parens $ toDoc x <+> text op <+> toDoc y
+
+ops :: [(String, Int -> Int -> Int)]
+ops = [("+",(+)), ("-",(-)), ("*",(*)), ("/",div)]
+
+
+solve :: Int -> [Int] -> [Expr]
+solve res = filter ((Just res ==) . eval) . genAst
+  where
+    genAst [x] = [C x]
+    genAst xs  = do
+      (ys,zs) <- split xs
+      let f (Op op _ _) = op `notElem` ["+","*"] || ys <= zs
+      filter f $ Op <$> map fst ops <*> genAst ys <*> genAst zs
+
+    eval (C      x  ) = Just x
+    eval (Op "/" _ y) | Just 0 <- eval y = Nothing
+    eval (Op op  x y) = lookup op ops <*> eval x <*> eval y
+
+
+select :: Int -> [Int] -> [[Int]]
+select 0 _  = [[]]
+select n xs = [x:zs | k <- [0..length xs - n]
+                    , let (x:ys) = drop k xs
+                    , zs <- select (n - 1) ys
+                    ]
+
+split :: [Int] -> [([Int],[Int])]
+split xs = [(ys, xs \\ ys) | n <- [1..length xs - 1]
+                           , ys <- nub . sort $ select n xs
+                           ]
+
+
+main = mapM_ (putStrLn . render . toDoc) $ solve 24 [2,3,8,9]