go-fringe.go: Language change: `closed' function on channels has gone.

[fringe] / haskell-fringe.hs

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

import IO
import System
import Monad

-----------------------------------------------------------------------------
--- Parser combinators.

-- A very simple parser monad.
newtype Parser t a = Parser { runparse :: [t] -> Either String (a, [t]) }

instance Monad (Parser t) where
  return x = Parser $ \ts -> Right (x, ts)
  fail err = Parser $ \_ -> Left err
  (Parser p) >>= f = Parser $ \ts -> case p ts of
                                       Right (x, ts) -> runparse (f x) ts
                                       Left err -> Left err

-- Access to the token stream.
peek = Parser $ \ts -> case ts of
                         t:_ -> Right (Just t, ts)
                         _ -> Right (Nothing, ts)

step = Parser $ \ts -> case ts of
                         _:ts -> Right ((), ts)
                         _ -> Left "unexpected end-of-file"

-- Run a parser, getting the final value out.
parse ts p = case runparse p ts of
               Right (x, _) -> Right x
               Left err -> Left err

-- If the current token satisfies PRED then return it; otherwise fail with
-- ERR.
satisfies pred err = do
  r <- peek
  case r of
    Just t | pred t -> do step; return t
    _ -> fail err

-- Return the next token if there is one; otherwise fail with ERR.
anytok err = satisfies (const True) err

-- If the current character matches D then return it; otherwise fail with a
-- suitable error.
delim d = satisfies (\c -> c == d) ("missing " ++ [d])

-- If at end of file then succeed; otherwise fail with a suitable error.
eof = do
  r <- peek
  case r of
    Nothing -> return ()
    _ -> fail "trailing junk"

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

-- 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 = parse cs $ do t <- tree; eof; return t
 where
  tree = do
    r <- peek
    case r of
      Just '(' -> do
        step; left <- tree; c <- anytok "no data"; right <- tree; delim ')'
        return $ Node left c right
      _ -> return Leaf

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