Return Styles: Pseud0ch, Terminal, Valhalla, NES, Geocities, Blue Moon. Entire thread

/prog/ challenge [HASKELL]

Name: Anonymous 2008-05-09 13:15

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: Anonymous 2008-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

Newer Posts
Don't change these.
Name: Email:
Entire Thread Thread List