scheme: Use `resume' to switch coroutines.

[fringe] / haskell-fringe.hs

-- -*-haskell-*-
--
-- Haskell implementation of a `same-fringe' solver.

import IO
import System
import Monad

-----------------------------------------------------------------------------
-- Tree data type.

data Tree a = Leaf | Node (Tree a, a, Tree a) deriving (Show)

-- Return the elements inorder, as a list.
fringe t = gather t [] where
  gather Leaf ns = ns
  gather (Node (l, x, r)) ns = gather l (x : gather r ns)

-- Answer whether two trees have the same fringe.
sameFringe t tt = fringe t == fringe tt -- trivial!

-----------------------------------------------------------------------------
-- Parsing.

-- Turn Either String a into a monad expressing computatations which can fail
-- with a useful error message.
instance Monad (Either String) where
  return = Right
  fail = Left
  Right x >>= f = f x
  Left l >>= _ = Left l

-- Parse a tree from the description in CS.  The syntax is:
--
--      tree ::= empty | `(' tree char tree `)'
--
-- disambiguated by deciding that `(' starts a tree wherever a tree is
-- expected.
parseTree cs = do
  (t, cs) <- parse cs
  if cs == [] then return t else fail "trailing junk"
 where
  parse ('(':cs) = do
    (left, cs) <- parse cs
    case cs of
      [] -> fail "no data"
      (c:cs) -> do
        (right, cs) <- parse cs
        case cs of
          (')':cs) -> return (Node (left, c, right), cs)
          _ -> fail "missing )"
  parse cs = return (Leaf, cs)

-----------------------------------------------------------------------------
-- Main program.

-- Report MSG as an error and quit.
bail msg = do
  prog <- getProgName
  hPutStrLn stderr (prog ++ ": " ++ msg)
  exitFailure

-- Main program.
main = do
  argv <- getArgs
  case argv of
    [arg] -> case parseTree arg of
               Right t -> do
                 mapM_ putChar (fringe t)
                 putChar '\n'
               Left err -> bail err
    [a, b] -> case (parseTree a, parseTree b) of
                (Right t, Right tt) ->
                  if sameFringe t tt then
                    putStrLn "match"
                  else
                    putStrLn "no match"
                (Left err, _) -> bail err
                (_, Left err) -> bail err
    _ -> bail "bad args"

----- That's all, folks -----------------------------------------------------