chiark - git - mdw - fringe/blob - haskell-fringe.hs

   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 -----------------------------------------------------