Entry tags:

cpp, haskell, программирование, решение

Снова про задачку.

module Main(main) where

import Char
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Monad.State

type CellRef = (String,String)

data Cell =
		CEmpty
	|	CError	String
	|	CInt	Int
	|	CText	String
	|	CFormulae	CExpr

data BinOp =
		BPlus
	|	BMinus
	|	BMul
	|	BDiv

data CExpr =
		CECell	CellRef
	|	CEInt	Int
	|	CEBin	BinOp	CExpr	CExpr

instance Show Cell where
	show CEmpty = ""
	show (CError s) = '#':s
	show (CInt i) = show i
	show (CText t) = t
	show (CFormulae e) = '=':show e

instance Show BinOp where
	show BPlus = "+"
	show BMinus = "-"
	show BMul = "*"
	show BDiv = "/"

instance Show CExpr where
	show (CECell (r,c)) = (c)++r
	show (CEInt i) = show i
	show (CEBin op a b) = show a++show op++show b

splitByTab l = split Nothing l
	where
		split Nothing [] = []
		split (Just acc) [] = [reverse acc]
		split acc (x:xs)
			| x == '\t' = case acc of
				Nothing -> []:split Nothing xs
				Just acc -> reverse acc:split Nothing xs
			| otherwise = case acc of
				Nothing -> split (Just [x]) xs
				Just acc -> split (Just $ x:acc) xs

tabbedListLine = do
	l <- getLine
	return $ splitByTab l

parseWH :: IO (Int,Int)
parseWH = do
	hw <- tabbedListLine
	case hw of
		[hs,ws] -> return (read ws,read hs)
		_ -> error "Illegal height and width line."

allindexes = chars1++nextchars chars1
	where
		chars = ['A'..'Z']
		chars1 = map (\x -> [x]) chars
		nextchars pcs = let cs' = [ c:cs | c <- chars, cs <- pcs] in cs'++nextchars cs'
parseCells w h = parselines M.empty 1
	where
		parselines cells j
			| j > h = return cells
			| otherwise = do
				cells' <- parseline j
				parselines (M.union cells cells') (j+1)
		indexes j = map (\x -> (show j,x)) $ take w allindexes
		parseline j = do
			l <- tabbedListLine
			return $ M.fromList $ zip (indexes j) $ filter notEmpty $ (map parse l)
		notEmpty CEmpty = False
		notEmpty _ = True
		parse "" = CEmpty
		parse ('\'':text) = CText text
		parse ('=':formulae) = parseexpr formulae
		parse i@(x:xs)
			| isDigit x = CInt (read i)
			| otherwise = CError "NAI"
		parseexpr "" = CError "NoExpr"
		parseexpr e = case pexpr e of
			Just e -> CFormulae e
			Nothing -> CError "Parse"
pexpr e = case parg e of
	Just (a,rem) -> case rem of
		(bop:args) -> case binop bop of
			Just bop -> case pexpr args of
				Just b -> Just $ CEBin bop a b
				Nothing -> Nothing
			Nothing -> Nothing
		_ -> Just a
	Nothing -> Nothing
	where
		binop '+' = Just BPlus
		binop '-' = Just BMinus
		binop '*' = Just BMul
		binop '/' = Just BDiv
		binop _ = Nothing
		parg [] = Nothing
		parg e@(c:cs)
			| isDigit c = let
					(n,rest) = span isDigit e
				in
					Just (CEInt (read n),rest)
			| isAlpha c = let
					(c,restc) = span isAlpha e
					(r,restr) = span isDigit restc
				in case (c,r) of
					([],_) -> Nothing
					(c,[]) -> Nothing
					(c,r) -> Just (CECell (r,map toUpper c),restr)
			| otherwise = Nothing

dig c = fromEnum (toUpper c)-fromEnum 'A'+1
base = dig 'z'+1
colToInt col = acc 0 $ map dig col
	where
		acc sum [] = sum
		acc sum (c:cs) = acc (sum*base+c) cs
intToCol :: Int -> String
intToCol 1 = "A"
intToCol i = map (toEnum . (fromEnum 'A'+)) $ reverse $ mods i
	where
		mods 0 = []
		mods x = let (d,m) = divMod x base in (m-1):mods d

celllookup i j cells = case M.lookup (i,j) cells of
	Nothing -> error $ "empty looking up "++show (i,j) -- CEmpty
	Just x -> x

getcell i j = do
	cells <- get
	return $ celllookup i j cells
setcell i j cell = do
	cells <- get
	put $ M.adjust (const cell) (i,j) cells
markerror i j = do
	x <- getcell i j
	setcell i j (CError "cycle")
	return x
			

printCells w h cells = print 1
	where
		printrow i j
			| j<=w = do
				putStr (show $ celllookup (show i) (intToCol j) cells)
				if j/=w then putStr "\t" else return ()
				printrow i (j+1)
			| otherwise = putStrLn ""
		print i
			| i <= h = do
				printrow i 1
				print (i+1)
			| otherwise = return ()

evalcells cells = execState (eval formulaes) cells
	where
		allcells = M.toList cells
		formulaes = map (\((i,j),_) -> (i,j)) $ filter isformulae allcells
		isformulae (_,CFormulae _) = True
		isformulae _ = False
		eval ((i,j):fs) = do
			evalcell i j
			eval fs
		eval [] = return ()
		evalcell i j = do
			x <- getcell i j
			case x of
				CFormulae expr -> do
					markerror i j
					r <- evalexpr expr
					setcell i j r
					return r
				v -> return v
		evalexpr (CECell (i,j)) = evalcell i j
		evalexpr (CEInt i) = return $ CInt i
		evalexpr (CEBin op a b) = do
			ar <- evalexpr a
			case ar of
				CError _ -> return ar
				x -> evalbin op ar b
		evalbin op ar b = case b of
			CEBin op' a' b -> do
				ar' <- evalexpr a'
				evalbin op' (apply op ar ar') b
			_ -> do
				br <- evalexpr b
				return $ apply op ar br
		apply _ ar@(CError _) _ = ar
		apply _ _ br@(CError _) = br
		apply op (CInt x) (CInt y) = case op of
			BPlus -> CInt $ x + y
			BMinus -> CInt $ x - y
			BMul -> CInt $ x * y
			BDiv
				| y == 0 -> CError "DBZ"
				| otherwise -> CInt $ x `div` y
		apply _  _ _ = CError "InvOp"


main = do
	(width,height) <- parseWH
	cells <- parseCells width height
	printCells width height $ evalcells cells

Выдержать "промышленный уровень" мне не удалось. ;)

Пальцы сами не хотят писать evalCells или cellLookup. ;)

Три часа работы. Два затруднения - нумерация ячеек и порядок вычисления выражений (откель там и появился evalbin;).

С циклами проблем не возникло, по крайней мере, в первом приближении. Есть небольшая неприятность - если встречается цикл, то сообщение об ошибке из него распространяется на все ссылающиеся на этот цикл элементы.

Проблем с проектированием типов данных (на это делается упор при рассмотрении решения на C++) не возникло.

Расширение в сторону операций со строками делается просто - добавляются необходимые сравнения с образцом в apply.

Для обработки больших таблиц необходимо не хранить пустые элементы в cells (сейчас они хранятся).

allindexes = fix nextchars (map return chars)
    where
        chars  = ['A'..'Z']
        nextchars f pcs = pcs ++ f [x:xs | x <- chars, xs <- pcs]