3 --- Haskell implementation of a `same-fringe' solver.
9 -----------------------------------------------------------------------------
10 --- Parser combinators.
12 -- A very simple parser monad.
13 newtype Parser t a = Parser { runparse :: [t] -> Either String (a, [t]) }
15 instance Monad (Parser t) where
16 return x = Parser $ \ts -> Right (x, ts)
17 fail err = Parser $ \_ -> Left err
18 (Parser p) >>= f = Parser $ \ts -> case p ts of
19 Right (x, ts) -> runparse (f x) ts
22 -- Access to the token stream.
23 peek = Parser $ \ts -> case ts of
24 t:_ -> Right (Just t, ts)
25 _ -> Right (Nothing, ts)
27 step = Parser $ \ts -> case ts of
28 _:ts -> Right ((), ts)
29 _ -> Left "unexpected end-of-file"
31 -- Run a parser, getting the final value out.
32 parse ts p = case runparse p ts of
33 Right (x, _) -> Right x
36 -- If the current token satisfies PRED then return it; otherwise fail with
38 satisfies pred err = do
41 Just t | pred t -> do step; return t
44 -- Return the next token if there is one; otherwise fail with ERR.
45 anytok err = satisfies (const True) err
47 -- If the current character matches D then return it; otherwise fail with a
49 delim d = satisfies (\c -> c == d) ("missing " ++ [d])
51 -- If at end of file then succeed; otherwise fail with a suitable error.
56 _ -> fail "trailing junk"
58 -----------------------------------------------------------------------------
61 data Tree a = Leaf | Node (Tree a) a (Tree a) deriving (Show)
63 -- Return the elements inorder, as a list.
64 fringe t = gather t [] where
66 gather (Node l x r) ns = gather l (x : gather r ns)
68 -- Answer whether two trees have the same fringe.
69 sameFringe t tt = fringe t == fringe tt -- trivial!
71 -- Parse a tree from the description in CS. The syntax is:
73 -- tree ::= empty | `(' tree char tree `)'
75 -- disambiguated by deciding that `(' starts a tree wherever a tree is
77 parseTree cs = parse cs $ do t <- tree; eof; return t
83 step; left <- tree; c <- anytok "no data"; right <- tree; delim ')'
84 return $ Node left c right
87 -----------------------------------------------------------------------------
90 -- Report MSG as an error and quit.
93 hPutStrLn stderr (prog ++ ": " ++ msg)
100 [arg] -> case parseTree arg of
102 mapM_ putChar (fringe t)
105 [a, b] -> case (parseTree a, parseTree b) of
106 (Right t, Right tt) ->
107 if sameFringe t tt then
111 (Left err, _) -> bail err
112 (_, Left err) -> bail err
115 ----- That's all, folks -----------------------------------------------------