Commit | Line | Data |
---|---|---|
2bd37ef1 MW |
1 | -- -*-haskell-*- |
2 | -- | |
3 | -- Haskell implementation of a `same-fringe' solver. | |
4 | ||
5 | import IO | |
6 | import System | |
7 | import Monad | |
8 | ||
9 | ----------------------------------------------------------------------------- | |
10 | -- Tree data type. | |
11 | ||
12 | data Tree a = Leaf | Node (Tree a, a, Tree a) deriving (Show) | |
13 | ||
14 | -- Return the elements inorder, as a list. | |
15 | fringe t = gather t [] where | |
16 | gather Leaf ns = ns | |
17 | gather (Node (l, x, r)) ns = gather l (x : gather r ns) | |
18 | ||
19 | -- Answer whether two trees have the same fringe. | |
20 | sameFringe t tt = fringe t == fringe tt -- trivial! | |
21 | ||
22 | ----------------------------------------------------------------------------- | |
23 | -- Parsing. | |
24 | ||
25 | -- Turn Either String a into a monad expressing computatations which can fail | |
26 | -- with a useful error message. | |
27 | instance Monad (Either String) where | |
28 | return = Right | |
29 | fail = Left | |
30 | Right x >>= f = f x | |
31 | Left l >>= _ = Left l | |
32 | ||
33 | -- Parse a tree from the description in CS. The syntax is: | |
34 | -- | |
35 | -- tree ::= empty | `(' tree char tree `)' | |
36 | -- | |
37 | -- disambiguated by deciding that `(' starts a tree wherever a tree is | |
38 | -- expected. | |
39 | parseTree cs = do | |
40 | (t, cs) <- parse cs | |
41 | if cs == [] then return t else fail "trailing junk" | |
42 | where | |
43 | parse ('(':cs) = do | |
44 | (left, cs) <- parse cs | |
45 | case cs of | |
46 | [] -> fail "no data" | |
47 | (c:cs) -> do | |
48 | (right, cs) <- parse cs | |
49 | case cs of | |
50 | (')':cs) -> return (Node (left, c, right), cs) | |
51 | _ -> fail "missing )" | |
52 | parse cs = return (Leaf, cs) | |
53 | ||
54 | ----------------------------------------------------------------------------- | |
55 | -- Main program. | |
56 | ||
57 | -- Report MSG as an error and quit. | |
58 | bail msg = do | |
59 | prog <- getProgName | |
60 | hPutStrLn stderr (prog ++ ": " ++ msg) | |
61 | exitFailure | |
62 | ||
63 | -- Main program. | |
64 | main = do | |
65 | argv <- getArgs | |
66 | case argv of | |
67 | [arg] -> case parseTree arg of | |
68 | Right t -> do | |
69 | mapM_ putChar (fringe t) | |
70 | putChar '\n' | |
71 | Left err -> bail err | |
72 | [a, b] -> case (parseTree a, parseTree b) of | |
73 | (Right t, Right tt) -> | |
74 | if sameFringe t tt then | |
75 | putStrLn "match" | |
76 | else | |
77 | putStrLn "no match" | |
78 | (Left err, _) -> bail err | |
79 | (_, Left err) -> bail err | |
80 | _ -> bail "bad args" | |
81 | ||
82 | ----- That's all, folks ----------------------------------------------------- |