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 --- Parser combinators.
  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 -----------------------------------------------------------------------------
  59 --- Tree data type.
  60
  61 data Tree a = Leaf | Node (Tree a) a (Tree a) deriving (Show)
  62
  63 -- Return the elements inorder, as a list.
  64 fringe t = gather t [] where
  65   gather Leaf ns = ns
  66   gather (Node l x r) ns = gather l (x : gather r ns)
  67
  68 -- Answer whether two trees have the same fringe.
  69 sameFringe t tt = fringe t == fringe tt -- trivial!
  70
  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.
  77 parseTree cs = parse cs $ do t <- tree; eof; return t
  78  where
  79   tree = do
  80     r <- peek
  81     case r of
  82       Just '(' -> do
  83         step; left <- tree; c <- anytok "no data"; right <- tree; delim ')'
  84         return $ Node left c right
  85       _ -> return Leaf
  86
  87 -----------------------------------------------------------------------------
  88 --- Main program.
  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 -----------------------------------------------------