--- -*-haskell-*-
---
--- Haskell implementation of a `same-fringe' solver.
+--- -*-haskell-*-
+---
+--- Haskell implementation of a `same-fringe' solver.
import IO
import System
import Monad
-----------------------------------------------------------------------------
--- Tree data type.
+--- Parser combinators.
+
+-- A very simple parser monad.
+newtype Parser t a = Parser { runparse :: [t] -> Either String (a, [t]) }
+
+instance Monad (Parser t) where
+ return x = Parser $ \ts -> Right (x, ts)
+ fail err = Parser $ \_ -> Left err
+ (Parser p) >>= f = Parser $ \ts -> case p ts of
+ Right (x, ts) -> runparse (f x) ts
+ Left err -> Left err
+
+-- Access to the token stream.
+peek = Parser $ \ts -> case ts of
+ t:_ -> Right (Just t, ts)
+ _ -> Right (Nothing, ts)
+
+step = Parser $ \ts -> case ts of
+ _:ts -> Right ((), ts)
+ _ -> Left "unexpected end-of-file"
+
+-- Run a parser, getting the final value out.
+parse ts p = case runparse p ts of
+ Right (x, _) -> Right x
+ Left err -> Left err
+
+-- If the current token satisfies PRED then return it; otherwise fail with
+-- ERR.
+satisfies pred err = do
+ r <- peek
+ case r of
+ Just t | pred t -> do step; return t
+ _ -> fail err
+
+-- Return the next token if there is one; otherwise fail with ERR.
+anytok err = satisfies (const True) err
+
+-- If the current character matches D then return it; otherwise fail with a
+-- suitable error.
+delim d = satisfies (\c -> c == d) ("missing " ++ [d])
+
+-- If at end of file then succeed; otherwise fail with a suitable error.
+eof = do
+ r <- peek
+ case r of
+ Nothing -> return ()
+ _ -> fail "trailing junk"
+
+-----------------------------------------------------------------------------
+--- Tree data type.
-data Tree a = Leaf | Node (Tree a, a, Tree a) deriving (Show)
+data Tree a = Leaf | Node (Tree a) a (Tree a) deriving (Show)
-- Return the elements inorder, as a list.
fringe t = gather t [] where
gather Leaf ns = ns
- gather (Node (l, x, r)) ns = gather l (x : gather r ns)
+ gather (Node l x r) ns = gather l (x : gather r ns)
-- Answer whether two trees have the same fringe.
sameFringe t tt = fringe t == fringe tt -- trivial!
------------------------------------------------------------------------------
--- Parsing.
-
--- Turn Either String a into a monad expressing computatations which can fail
--- with a useful error message.
-instance Monad (Either String) where
- return = Right
- fail = Left
- Right x >>= f = f x
- Left l >>= _ = Left l
-
-- Parse a tree from the description in CS. The syntax is:
--
-- tree ::= empty | `(' tree char tree `)'
--
-- disambiguated by deciding that `(' starts a tree wherever a tree is
-- expected.
-parseTree cs = do
- (t, cs) <- parse cs
- if cs == [] then return t else fail "trailing junk"
+parseTree cs = parse cs $ do t <- tree; eof; return t
where
- parse ('(':cs) = do
- (left, cs) <- parse cs
- case cs of
- [] -> fail "no data"
- (c:cs) -> do
- (right, cs) <- parse cs
- case cs of
- (')':cs) -> return (Node (left, c, right), cs)
- _ -> fail "missing )"
- parse cs = return (Leaf, cs)
+ tree = do
+ r <- peek
+ case r of
+ Just '(' -> do
+ step; left <- tree; c <- anytok "no data"; right <- tree; delim ')'
+ return $ Node left c right
+ _ -> return Leaf
-----------------------------------------------------------------------------
--- Main program.
+--- Main program.
-- Report MSG as an error and quit.
bail msg = do