DailyProgrammer Challenge #206h Compact Solution (Recurrence Relations, part 2)

c206h-compact.hs

import Data.Maybe
import Data.List
import Data.Char

data Successor = Literal Double
               | Previous Int
               | Binary (Double -> Double -> Double) Successor Successor
               | Unary (Double -> Double) Successor

type Term = (Int, Double)
type Series = [Term]

getTerm series i = lookup i series

evalSucc series i (Previous j) = fromJust $ getTerm series (i - j)
evalSucc series i (Binary f l r) = (evalSucc series i l) `f` (evalSucc series i r)
evalSucc series i (Literal x) = x

getReq (Previous i) = [-i]
getReq (Binary _ l r) = getReq l `union` getReq r
getReq (Literal _) = []

isDefinedAt series req i = all (\j -> isJust $ getTerm series (i + j)) req 

getDefinedIndices series req =
    let order        = -(minimum req)
        knownIndices = map ((+)order . fst) series
    in  filter (isDefinedAt series req) knownIndices

getSeries initial succ =
    initial ++ (getSeriesR initial) where
        req            = getReq succ
        getSeriesR acc =
            let newTerms = map (\i -> (i, evalSucc acc i succ))
                         $ dropWhile (\i -> isJust $ find ((==) i . fst) acc)
                         $ getDefinedIndices acc req
            in  if null newTerms
                    then []
                    else newTerms ++ (getSeriesR (acc ++ newTerms))

parseSuccessor s = parseSuccessorR s [] where
    validOps                  = "+-*/^" `zip` [(+), (-), (*), (/), (\ b p -> exp $ p * (log b))]
    validRealChars            = "0123456789.eE+-"
    parseSuccessorR [] []     = Left $ "Nothing on stack after parsing."
    parseSuccessorR [] [succ] = Right succ
    parseSuccessorR [] stk    = Left $ (show $ length stk) ++ " too many things on stack after parsing."
    parseSuccessorR (c:s) stk
        | c == ' '            = parseSuccessorR s stk
        | c == '('            = let (index, s') = break ((==) ')') s
                                in  parseSuccessorR (tail s') $ (Previous $ read index):stk
        | c `elem` (map fst validOps) 
                              = case stk of 
                                    r:l:stk' -> parseSuccessorR s $ (Binary (fromJust $ lookup c validOps) l r):stk'
                                    _        -> Left $ "Not enough operands for " ++ [c] ++ "."
        | isDigit c           = let (value, s') = span (\ c' -> c' `elem` validRealChars) (c:s)
                                in  parseSuccessorR s' $ (Literal $ read value):stk
        | otherwise           = Left $ "Unknown character " ++ [c] ++ "."

parseTerm s = let (index, s') = break ((==) ':') s
                  value = tail s'
              in  (read index, read value)

splitOneOf delims l = splitOneOfR delims l [] [] where
    adjoin cs parts                = if null cs then parts else (reverse cs):parts
    splitOneOfR delims [] cs parts = reverse $ adjoin cs parts
    splitOneOfR delims (c:s) cs parts
        | c `elem` delims          = splitOneOfR delims s [] $ adjoin cs parts
        | otherwise                = splitOneOfR delims s (c:cs) parts

main = do content <- getContents
          let (succInput:rest)    = splitOneOf "\r\n" content
          let (termsInput, count) = (init rest, read $ last rest)              
              (terms, succParsed) = (sortBy (\ a b -> fst a `compare` fst b) $ map parseTerm termsInput, parseSuccessor succInput)
          case succParsed of
              Left err   -> putStrLn $ "In successor: " ++ err
              Right succ -> putStrLn
                          $ intercalate "\n"
                          $ map (\ (i, x) -> (show i) ++ ": " ++ (show x))
                          $ takeWhile (\t -> fst t <= count)
                          $ getSeries terms succ