Re: [Haskell] Решение задачи К
От: haskell_beginner  
Дата: 27.11.07 18:40
Оценка:
Здравствуйте, BulatZiganshin, Вы писали:

BZ>поскольку каждый архитектор должен построить дом, подписать письмо четырёх и решить задачу К, я тоже не выдержал. см. http://www.haskell.org/haskellwiki/Ru/Problem_K


А не проще ли было как-то поимперативнее? Я хаскель знаю слабо, но вот в духе потока сознания родилось следующее:

import Control.Monad
import Data.Array.IO
import Data.IORef
import Data.List
import Data.Char
import Text.ParserCombinators.Parsec
import Control.Exception
import Prelude hiding (catch)

--------------------------------------------------------------------------------------

data Table = Table
           { tWidth  :: Int
           , tHeight :: Int
           , tData   :: IOArray (Int,Int) Cell
           }

data Cell  = CEmpty
           | CNumber Integer
           | CText   String
           | CExpr   Expr
           | CError  String

data Expr  = ESimple Term
           | EBinary Expr Op Term

data Term  = ENumber Integer
           | ERef    Int Int

data Op    = OPlus
           | OMinus
           | OMul
           | ODiv
           deriving Eq

numOps = [(OPlus, (+)), (OMinus, (-)), (OMul, (*)), (ODiv, div)]

evalOp (CNumber n1, op, CNumber n2) = CNumber $ n1 `f` n2 where Just (_,f) = find ((== op).fst) numOps
evalOp _                            = errEval

errParse    = CError "#Parse"
errEval     = CError "#Eval"
errIdx      = CError "#Index"
errExpr     = CError "#Expr" -- unevaluated

instance Show Cell where
  show CEmpty      = ""
  show (CNumber n) = show n
  show (CText   t) = t
  show (CExpr   e) = show errExpr
  show (CError  e) = e

--------------------------------------------------------------------------------------

parseTable :: String -> IO Table
parseTable input = do
  case lines input of
    []     -> error "invalid input"
    (l:ls) -> do let [h,w] = map toInt . split $ l
                 dat <- newArray ((0,0),(h-1,w-1)) CEmpty :: IO (IOArray (Int,Int) Cell)
                 forM_ (zip [0..] ls) $ \(i,l) ->
                   forM_ (zip [0..] $ split l) $ \(j,x) ->
                     writeArray dat (i,j) $ parseCell x
                 return Table { tWidth = w, tHeight = h, tData = dat }
  where toInt = read :: String -> Int
        split = lines . map (\c -> if c == '\t' then '\n' else c)

parseCell :: String -> Cell
parseCell ""                = CEmpty
parseCell ('\'':s)          = CText s
parseCell ('=' :s)          = case parse expr "" s of
                                Right e -> CExpr e
                                Left  _ -> errParse
parseCell s | all isDigit s = CNumber (read s)
            | otherwise     = errParse

expr   = do { t <- term; rest $ ESimple t }
rest e = do { eof; return e }
     <|> do { o <- op; t <- term; rest $ EBinary e o t }

op    = foldl1 (<|>) $
        map (\(ch,op) -> do { char ch; return op })
        [('+',OPlus), ('-', OMinus), ('*', OMul), ('/', ODiv)]

term   = do { n <- number; return $ ENumber n }
     <|> do { a <- letter; n <- number; return $ ERef (fromIntegral n - 1) (ord (toUpper a) - ord 'A') }

number = do { ds <- many1 digit; return (read ds :: Integer) }

--------------------------------------------------------------------------------------

printTable :: Table -> IO ()
printTable (Table w h d) = do
  a <- newArray ((0,0),(h-1,w-1)) "" :: IO (IOArray (Int,Int) String)
  forM_ [(i,j) | i <- [0..h-1], j <- [0..w-1]] $ \(i,j) -> do
    c <- readArray d (i,j)
    t <- evaluate (show c) `catch` (const $ return $ show errEval)
    writeArray a (i,j) t
  maxw <- foldl (\a x -> a `max` length x) 1 `liftM` getElems a
  forM_ [0..h-1] $ \i -> do
    (putStrLn . concat . intersperse "  " . map (pad maxw)) =<< (forM [0..w-1] $ \j -> readArray a (i,j))
  where pad w s = s ++ replicate (w - length s) ' '

--------------------------------------------------------------------------------------

data CState = CInit | CEval | CDone deriving Eq

evalTable :: Table -> IO Table
evalTable (Table w h d) = do
  st <- newArray ((0,0),(h-1,w-1)) CInit :: IO (IOArray (Int,Int) CState)
  d' <- mapArray id d -- copy ("let d' = d" evaluates table in place)
  let eval ij = do
        curst <- readArray st ij
        case curst of
          CDone -> return ()
          CEval -> error "eval"
          CInit -> do writeArray st ij CEval
                      c  <- readArray d' ij
                      c' <- case c of
                              CExpr e -> evalExpr e
                              _       -> return c
                      writeArray d' ij c'
                      writeArray st ij CDone

      evalExpr (ESimple t)     = evalTerm t
      evalExpr (EBinary e o t) = do e' <- evalExpr e
                                    t' <- evalTerm t
                                    return $ evalOp (e', o, t')

      evalTerm (ENumber n)     = return $ CNumber n
      evalTerm (ERef i j)      = if i < 0 || j < 0 || i >= h || j >= w
                                   then return errIdx
                                   else do
                                     tmpst <- readArray st (i,j)
                                     if tmpst == CEval
                                       then return errEval
                                       else do if tmpst == CInit then eval (i,j) else return ()
                                               c' <- readArray d' (i,j)
                                               case c' of
                                                 CNumber _ -> return c'
                                                 _         -> return errEval

  forM_ [(i,j) | i <- [0..h-1], j <- [0..w-1]] eval
  return $ Table w h d'

--------------------------------------------------------------------------------------

main = printTable =<< evalTable =<< parseTable =<< getContents


Наверное, если знать язык получше, можно упростить и сократить.
 
Подождите ...
Wait...
Пока на собственное сообщение не было ответов, его можно удалить.