Commit | Line | Data |
---|---|---|
eee4486f MW |
1 | --- -*-haskell-*- |
2 | --- | |
3 | --- Haskell implementation of a `same-fringe' solver. | |
2bd37ef1 MW |
4 | |
5 | import IO | |
6 | import System | |
7 | import Monad | |
8 | ||
9 | ----------------------------------------------------------------------------- | |
eee4486f | 10 | --- Parser combinators. |
d87584d7 MW |
11 | |
12 | -- A very simple parser monad. | |
13 | newtype Parser t a = Parser { runparse :: [t] -> Either String (a, [t]) } | |
14 | ||
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 | |
20 | Left err -> Left err | |
21 | ||
22 | -- Access to the token stream. | |
23 | peek = Parser $ \ts -> case ts of | |
24 | t:_ -> Right (Just t, ts) | |
25 | _ -> Right (Nothing, ts) | |
26 | ||
27 | step = Parser $ \ts -> case ts of | |
28 | _:ts -> Right ((), ts) | |
29 | _ -> Left "unexpected end-of-file" | |
30 | ||
31 | -- Run a parser, getting the final value out. | |
32 | parse ts p = case runparse p ts of | |
33 | Right (x, _) -> Right x | |
34 | Left err -> Left err | |
35 | ||
36 | -- If the current token satisfies PRED then return it; otherwise fail with | |
37 | -- ERR. | |
38 | satisfies pred err = do | |
39 | r <- peek | |
40 | case r of | |
41 | Just t | pred t -> do step; return t | |
42 | _ -> fail err | |
43 | ||
44 | -- Return the next token if there is one; otherwise fail with ERR. | |
45 | anytok err = satisfies (const True) err | |
46 | ||
47 | -- If the current character matches D then return it; otherwise fail with a | |
48 | -- suitable error. | |
49 | delim d = satisfies (\c -> c == d) ("missing " ++ [d]) | |
50 | ||
51 | -- If at end of file then succeed; otherwise fail with a suitable error. | |
52 | eof = do | |
53 | r <- peek | |
54 | case r of | |
55 | Nothing -> return () | |
56 | _ -> fail "trailing junk" | |
57 | ||
58 | ----------------------------------------------------------------------------- | |
eee4486f | 59 | --- Tree data type. |
2bd37ef1 | 60 | |
e4e035bf | 61 | data Tree a = Leaf | Node (Tree a) a (Tree a) deriving (Show) |
2bd37ef1 MW |
62 | |
63 | -- Return the elements inorder, as a list. | |
64 | fringe t = gather t [] where | |
65 | gather Leaf ns = ns | |
e4e035bf | 66 | gather (Node l x r) ns = gather l (x : gather r ns) |
2bd37ef1 MW |
67 | |
68 | -- Answer whether two trees have the same fringe. | |
69 | sameFringe t tt = fringe t == fringe tt -- trivial! | |
70 | ||
2bd37ef1 MW |
71 | -- Parse a tree from the description in CS. The syntax is: |
72 | -- | |
73 | -- tree ::= empty | `(' tree char tree `)' | |
74 | -- | |
75 | -- disambiguated by deciding that `(' starts a tree wherever a tree is | |
76 | -- expected. | |
d87584d7 | 77 | parseTree cs = parse cs $ do t <- tree; eof; return t |
2bd37ef1 | 78 | where |
d87584d7 MW |
79 | tree = do |
80 | r <- peek | |
81 | case r of | |
82 | Just '(' -> do | |
83 | step; left <- tree; c <- anytok "no data"; right <- tree; delim ')' | |
e4e035bf | 84 | return $ Node left c right |
d87584d7 | 85 | _ -> return Leaf |
2bd37ef1 MW |
86 | |
87 | ----------------------------------------------------------------------------- | |
eee4486f | 88 | --- Main program. |
2bd37ef1 MW |
89 | |
90 | -- Report MSG as an error and quit. | |
91 | bail msg = do | |
92 | prog <- getProgName | |
93 | hPutStrLn stderr (prog ++ ": " ++ msg) | |
94 | exitFailure | |
95 | ||
96 | -- Main program. | |
97 | main = do | |
98 | argv <- getArgs | |
99 | case argv of | |
100 | [arg] -> case parseTree arg of | |
101 | Right t -> do | |
102 | mapM_ putChar (fringe t) | |
103 | putChar '\n' | |
104 | Left err -> bail err | |
105 | [a, b] -> case (parseTree a, parseTree b) of | |
106 | (Right t, Right tt) -> | |
107 | if sameFringe t tt then | |
108 | putStrLn "match" | |
109 | else | |
110 | putStrLn "no match" | |
111 | (Left err, _) -> bail err | |
112 | (_, Left err) -> bail err | |
113 | _ -> bail "bad args" | |
114 | ||
115 | ----- That's all, folks ----------------------------------------------------- |