Use the loeb function: loeb :: Functor a => a (a x -> x) -> a x
loeb x = fmap (\a -> a (loeb x)) x
To implement a basic spreadsheet processor. The processor should accept input of the form: |##|A |B |C |D |
|01|(* B1 C1)|2 |3 |(* A1 2)|
The output from this example should be: |##|A |B |C |D |
|01|6 |2 |3 |12 |
Cells may contain number literals, references to other cells of the form <letter><number>, or function applications of the form (<function> *<args>).
Name:
Anonymous2008-05-09 16:44
OP here, I've got parsing and evaluation, but no writing yet; I'm about as lazy as my language!
module Main where
import Data.Array
import Control.Monad
import Data.List
import System.IO
import Control.Arrow
import qualified Text.ParserCombinators.Parsec as P
(.:) = (.) . (.)
split :: (Eq a) => a -> [a] -> [[a]]
split _ [] = [[]]
split delim (x:xs) | x == delim = [] : rest
| otherwise = (x : head rest) : tail rest
where rest = split delim xs
remove :: (Eq a) => a -> [a] -> [a]
remove x (y:ys) | x == y = remove x ys
| otherwise = y : remove x ys
remove x [] = []
loeb :: Functor a => a (a x -> x) -> a x
loeb x = fmap (\a -> a (loeb x)) x
type Cell = (Int, Char)
type Symbol = String
type Number = Double
data Expr = LitE Number
| RefE Cell
| AppE Symbol [Expr] deriving (Show)
type Prim = [Number] -> Number
prims :: [(Symbol, Prim)]
prims = map (second binop) $
[("+", (+)), ("-", (-)), ("*", (*)), ("/", (/))]
where binop prim [x, y] = prim x y
parseExpr :: (Monad m) => String -> m Expr
parseExpr x = case P.parse (P.between pad pad expr) [] x of
Left exc -> fail $ show exc
Right x' -> return x'
where expr = P.choice [app, ref, lit]
lit = do first <- (P.try $ sequence [P.char '-', P.digit]) P.<|>
liftM return P.digit
rest <- P.many $ P.digit P.<|> P.char '.'
return $ LitE $ read (first ++ rest)
ref = let column = P.oneOf ['A'..'Z']
row = liftM read $ P.many1 P.digit
in liftM2 (RefE .: flip (,)) column row
app = P.between (P.char '(' >> pad) (pad >> P.char ')') $
liftM2 AppE symbol $ pad >> P.sepBy1 expr pad1
[pad, pad1] = map ($ P.oneOf " \t") [P.many, P.many1]
symbol = let special = P.oneOf "!#$%&|*+-/:<.=>?@^_~"
first = P.letter P.<|> special
rest = P.choice [P.letter, P.digit, special]
in liftM2 (:) first (P.many rest)
type Sheet a = Array Cell a
eval :: Expr -> Sheet Number -> Number
eval (LitE lit) _ = lit
eval (RefE ref) sheet = sheet ! ref
eval (AppE fun args) sheet =
case lookup fun prims of
(Just f) -> f args'
Nothing -> error $ "eval: unknown builtin '" ++ fun ++ "'"
where args' = map (`eval` sheet) args
readSheet :: Handle -> IO (Sheet Expr)
readSheet handle =
do header <- getCells
let columns = map (head . remove ' ') (tail header)
(`unless` fail "readSheet: incorrect header format") $
nub (header !! 0) == "#" && (and $ zipWith (==) ['A'..'Z'] columns)
let loop n rows =
do isEOF <- hIsEOF handle
if isEOF then return $ reverse rows
else do (n':row) <- getCells
when (n /= read n') $
fail "readSheet: row number out of sync"
mapM parseExpr row >>= loop (n + 1) . (:rows)
rows <- loop 1 []
return $ listArray ((1, 'A'), (length rows, last columns)) $ concat rows
where getCells = liftM (remove [] . split '|') $ hGetLine handle
writeSheet :: Handle -> Sheet Number -> IO ()
writeSheet handle sheet = return () -- TODO
process :: Sheet Expr -> Sheet Number
process = loeb . fmap eval