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