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

   1 --- -*-haskell-*-
   2 ---
   3 --- Haskell implementation of a `same-fringe' solver.
   4
   5 import System.IO
   6 import System.Environment
   7 import System.Exit
   8 import Control.Monad
   9
  10 -----------------------------------------------------------------------------
  11 --- Parser combinators.
  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 -----------------------------------------------------------------------------
  60 --- Tree data type.
  61
  62 data Tree a = Leaf | Node (Tree a) a (Tree a) deriving (Show)
  63
  64 -- Return the elements inorder, as a list.
  65 fringe t = gather t [] where
  66   gather Leaf ns = ns
  67   gather (Node l x r) ns = gather l (x : gather r ns)
  68
  69 -- Answer whether two trees have the same fringe.
  70 sameFringe t tt = fringe t == fringe tt -- trivial!
  71
  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.
  78 parseTree cs = parse cs $ do t <- tree; eof; return t
  79  where
  80   tree = do
  81     r <- peek
  82     case r of
  83       Just '(' -> do
  84         step; left <- tree; c <- anytok "no data"; right <- tree; delim ')'
  85         return $ Node left c right
  86       _ -> return Leaf
  87
  88 -----------------------------------------------------------------------------
  89 --- Main program.
  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 -----------------------------------------------------