3 --- Haskell implementation of a `same-fringe' solver.
6 import System.Environment
10 -----------------------------------------------------------------------------
11 --- Parser combinators.
13 -- A very simple parser monad.
14 newtype Parser t a = Parser { runparse :: [t] -> Either String (a, [t]) }
16 instance Monad (Parser t) where
17 return x = Parser $ \ts -> Right (x, ts)
18 fail err = Parser $ \_ -> Left err
19 (Parser p) >>= f = Parser $ \ts -> case p ts of
20 Right (x, ts) -> runparse (f x) ts
23 -- Access to the token stream.
24 peek = Parser $ \ts -> case ts of
25 t:_ -> Right (Just t, ts)
26 _ -> Right (Nothing, ts)
28 step = Parser $ \ts -> case ts of
29 _:ts -> Right ((), ts)
30 _ -> Left "unexpected end-of-file"
32 -- Run a parser, getting the final value out.
33 parse ts p = case runparse p ts of
34 Right (x, _) -> Right x
37 -- If the current token satisfies PRED then return it; otherwise fail with
39 satisfies pred err = do
42 Just t | pred t -> do step; return t
45 -- Return the next token if there is one; otherwise fail with ERR.
46 anytok err = satisfies (const True) err
48 -- If the current character matches D then return it; otherwise fail with a
50 delim d = satisfies (\c -> c == d) ("missing " ++ [d])
52 -- If at end of file then succeed; otherwise fail with a suitable error.
57 _ -> fail "trailing junk"
59 -----------------------------------------------------------------------------
62 data Tree a = Leaf | Node (Tree a) a (Tree a) deriving (Show)
64 -- Return the elements inorder, as a list.
65 fringe t = gather t [] where
67 gather (Node l x r) ns = gather l (x : gather r ns)
69 -- Answer whether two trees have the same fringe.
70 sameFringe t tt = fringe t == fringe tt -- trivial!
72 -- Parse a tree from the description in CS. The syntax is:
74 -- tree ::= empty | `(' tree char tree `)'
76 -- disambiguated by deciding that `(' starts a tree wherever a tree is
78 parseTree cs = parse cs $ do t <- tree; eof; return t
84 step; left <- tree; c <- anytok "no data"; right <- tree; delim ')'
85 return $ Node left c right
88 -----------------------------------------------------------------------------
91 -- Report MSG as an error and quit.
94 hPutStrLn stderr (prog ++ ": " ++ msg)
101 [arg] -> case parseTree arg of
103 mapM_ putChar (fringe t)
106 [a, b] -> case (parseTree a, parseTree b) of
107 (Right t, Right tt) ->
108 if sameFringe t tt then
112 (Left err, _) -> bail err
113 (_, Left err) -> bail err
116 ----- That's all, folks -----------------------------------------------------