24p

main.hs

module Main where

import Data.Ratio
import Control.Applicative
import Data.List(delete)
import Data.Maybe

import Debug.Trace

type RatioI = Ratio Integer

data Op = Op { opFunc :: Maybe RatioI -> Maybe RatioI -> Maybe RatioI
             , opShow :: String
             }

data State = State { stRemain :: [RatioI]
                   , stValue  :: [Maybe RatioI]
                   , stStack  :: [Either String RatioI]
                   } deriving (Show, Eq)

search :: RatioI -> [Op] -> [State] -> Maybe State
search _ _ [] = Nothing
search tgt opList (st : stXs) = -- trace (show st) $
  if stRemain st == [] && (length (stValue st) < 2)
  then if stValue st == [Just tgt]
       then Just st
       else search tgt opList stXs
  else search tgt opList $ (search' opList st) ++ stXs

search' :: [Op] -> State -> [State]
search' opList st = let
  remain = stRemain st
  value  = stValue st
  stack  = stStack st
  stNumList = flip map remain $ \x -> State { stRemain = delete x remain
                                            , stValue = Just x : value
                                            , stStack = Right x : stack
                                            }
  stOpList = if length value < 2
             then []
             else let val0 = value !! 0
                      val1 = value !! 1
                      valR = drop 2 value in
                    flip map opList $ \op ->
                                        State { stRemain = remain
                                              , stValue = (opFunc op) val0 val1 : valR
                                              , stStack = Left (opShow op) : stack
                                              }
  in stNumList ++ stOpList

searchInit :: RatioI -> [Op] -> [RatioI] -> Maybe State
searchInit tgt opList remain = let
  st = State { stRemain = remain
             , stValue = []
             , stStack = []
             }
  in search tgt opList [st]

opAdd :: Op
opSub :: Op
opMul :: Op
opDiv :: Op

opAdd = Op { opFunc = liftA2 (+), opShow = "+" }
opSub = Op { opFunc = liftA2 (-), opShow = "-" }
opMul = Op { opFunc = liftA2 (*), opShow = "*" }
opDiv = Op { opFunc = \x y -> do
                         x0 <- x
                         y0 <- y
                         if y0 == 0 then Nothing else return $ x0 / y0
           , opShow = "/" }

defaultOpList :: [Op]
defaultOpList = [opAdd, opSub, opMul, opDiv]

main :: IO ()
main = do
  let list = do x <- [1..9]
                y <- [1..9]
                z <- [1..9]
                w <- [1..9]
                return [x,y,z,w]
  let res = filter isJust $ map (searchInit 24 defaultOpList) list
  putStrLn $ show $ (length res, length list)