Treehugger/Implementation

module Main where import Prelude hiding (zip) import Data.Char import Data.Maybe import Control.Monad.IO.Class import Control.Monad.Trans.Maybe import Text.ParserCombinators.ReadP --- data T a = B (T a) a (T a) data Z a = ZL (Z a) a (T a)         | M (T a) (T a)          | ZR (T a) a (Z a) zero = B zero (0 :: Int) zero zip (B l x r) = (x, M l r) plug x (ZL zl y r) = B (plug x zl) y r plug x (M l r) = B l x r plug x (ZR l y zr) = B l y (plug x zr) left v (ZL zl x r) = case left v zl of (y, zl') -> (y, ZL zl' x r) left v (M l r) = case zip l of (y, zl) -> (y, ZL zl v r) left v (ZR l y zr) = case left v zr of (y, zr') -> (y, ZR l y zr') right v (ZL zl x r) = case right v zl of (y, zl') -> (y, ZL zl' x r) right v (M l r) = case zip r of (y, zr) -> (y, ZR l v zr) right v (ZR l x zr) = case right v zr of (y, zr') -> (y, ZR l x zr') back v (ZL (M l' r') x r) = let t = plug v (M l' r') in return (x, M t r) back v (ZL zl x r) = do (e, zl') <- back v zl ; return $ (e, ZL zl' x r) back v (M l r) = Nothing back v (ZR l x (M l' r')) = let t = plug v (M l' r') in return (x, M l t) back v (ZR l x zr) = do (e, zr') <- back v zr ; return $ (e, ZR l x zr') --- data TH = INC | DEC | BCK | LFT | RHT | REP [TH] | DOT deriving Show exec' :: (Int, Z Int) -> [TH] -> MaybeT IO (Int, Z Int) exec' s [] = return s exec' s (i:is) = do s' <- exec s i ; exec' s' is exec :: (Int, Z Int) -> TH -> MaybeT IO (Int, Z Int) exec (v,z) INC = return (v+1,z) exec (v,z) DEC = return (v-1,z) exec (v,z) BCK = MaybeT. return $ back v z exec (v,z) LFT = return (left v z) exec (v,z) RHT = return (right v z) exec (0,z) (REP insts) = return (0,z) exec (v,z) (REP insts) = do s' <- exec' (v,z) insts ; exec s' (REP insts) exec (v,z) DOT = do liftIO (putStr [chr v]) ; return (v,z) --- th code = do runMaybeT (exec' (zip zero) code) ; putStrLn "" --- pTH = choice [ do char '+' ; return INC , do char '-' ; return DEC , do char '^' ; return BCK , do char '<' ; return LFT , do char '>' ; return RHT , do char '[' ; pRep , do char '.' ; return DOT ] pRep = do th <- many pTH ; char ']' ; return (REP th) parse text = case readP_to_S (do r <- many pTH ; eof ; return r) text of [(code,"")] -> Just code _ -> Nothing --- main = do input <- getContents let code = filter (`elem`"+-^<>[]."). takeWhile (/='#') $ input case parse code of  Nothing -> print ("Error in: " ++ input) Just program -> th program