Treehugger/Implementation

← Back to Treehugger

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