module: dylan-fringe
language: infix-dylan
author: Mark Wooding
copyright: (c) 2010 Mark Wooding

/* -*-dylan-*-
 *
 * Dylan implementation of a `same-fringe' solver.
 */

///--------------------------------------------------------------------------
/// Utilities.

define macro loop
  // loop (ESCAPE) BODY end [loop]
  //
  // Repeatedly evaluate the BODY, with ESCAPE bound to a procedure which
  // causes the loop to end immediately and yield its argument.

  { loop (?escape:variable) ?:body end }
    => { block (?escape) while (#t) ?body end end }
end;

///--------------------------------------------------------------------------
/// Nodes and trees.

// We specialize methods on trees, whether leaves or non-leaves, so we need a
// common superclass.
define abstract class <tree> (<collection>) end;

// A leaf is an empty tree.  We don't use #f because we need to specialize
// methods on empty trees too.  We only need one leaf, but there's no point
// in being petty about it.
define class <leaf> (<tree>) end;
define constant $leaf = make(<leaf>);

// A node is a tree which carries data and has subtrees.
define class <node> (<tree>)
  constant slot left :: <tree>, required-init-keyword: left:;
  constant slot right :: <tree>, required-init-keyword: right:;
  slot data, init-keyword: data:, init-value: #f;
end;

// Use method dispatch to decide whether a tree is a leaf.
define generic leaf?(tree) => (p :: <boolean>);
define method leaf?(tree :: <leaf>) => (p :: <boolean>) #t end;
define method leaf?(tree :: <node>) => (p :: <boolean>) #f end;

define method parse-tree
    (string :: <string>,
     #key start :: <integer> = 0,
          end: stop :: <integer> = string.size)
 => (tree :: <tree>)
  // Parse STRING, and return the tree described.
  //
  // The syntax is simple:
  //
  //    tree ::= empty | `(' tree char tree `)'
  //
  // The ambigity is resolved by always treating `(' as a tree when a tree is
  // expected.

  local method parse(i :: <integer>) => (tree :: <tree>, i :: <integer>)
          if (i >= stop | string[i] ~= '(')
            values($leaf, i)
          else
            let (left, i) = parse(i + 1);
            if (i >= stop) error("no data") end;
            let data = string[i];
            let (right, i) = parse(i + 1);
            if (i >= stop | string[i] ~= ')') error("missing )") end;
            values(make(<node>, left: left, right: right, data: data), i + 1)
          end
        end;
  let (tree, i) = parse(start);
  if (i ~= stop) error("trailing junk") end;
  tree
end;

define method print-object(tree :: <tree>, stream :: <stream>) => ()
  // Print a TREE to the given STREAM.  No newline is printed.

  local method recur(tree)
          unless (tree.leaf?)
            write(stream, "(");
            recur(tree.left);
            write-element(stream, tree.data);
            recur(tree.right);
            write(stream, ")");
          end
        end;
  recur(tree)
end;

///--------------------------------------------------------------------------
/// Iteration utilities.

define method iterator(coll :: <collection>) => (iter :: <function>)
  // Return a function which iterates over the collection COLL.
  //
  // Each call to the function returns two values: ANY? is false if the
  // collection is exhausted, or true if a new item was returned; and ITEM is
  // the item from the collection.  Obviously, ITEM is meaningful only if
  // ANY? is true.

  let (state, final, next, finished?, key, item, item-setter, copy) =
    forward-iteration-protocol(coll);
  method () => (any? :: <boolean>, item :: <object>)
    if (finished?(coll, state, final))
      values(#f, #f)
    else
      let this = item(coll, state);
      state := next(coll, state);
      values(#t, this)
    end
  end
end;

define method same-collections?
    (coll-a :: <collection>, coll-b :: <collection>) => (p :: <boolean>)
  // Answer whether COLL-A and COLL-B contain the same elements (according to
  // `=') in the same order.

  let iter-a = iterator(coll-a);
  let iter-b = iterator(coll-b);
  loop (done)
    let (any-a, item-a) = iter-a();
    let (any-b, item-b) = iter-b();
    case
      any-a ~= any-b => done(#f);
      ~ any-a => done(#t);
      item-a ~= item-b => done(#f);
    end
  end
end;

///--------------------------------------------------------------------------
/// Fringe iteration.

define class <tree-iteration-state> (<object>)
  // The iteration state for a tree.  We remember the current node, and a
  // closure which will produce the rest of the iteration.  Iteration states
  // are immutable.

  constant slot node :: <tree>, required-init-keyword: node:;
  constant slot next :: <function>, required-init-keyword: next:;
end;

define method forward-iteration-protocol(tree :: <tree>)
 => (state, final,
     next :: <function>, finished? :: <function>,
     this-key :: <function>,
     this-item :: <function>, this-item-setter :: <function>,
     copy :: <function>)
  // Iteration protocol implementation for the fringe of a binary tree.

  local method iter(tree, after)
          if (tree.leaf?)
            after()
          else
            iter(tree.left,
                 method ()
                   make(<tree-iteration-state>,
                        node: tree,
                        next: method () iter(tree.right, after) end)
                 end)
          end
        end;

  values(iter(tree, method () #f end),             // initial state
         #f,                                       // final state
         method (tree, state) state.next() end,    // next state
         method (tree, state, limit) ~ state end,  // finished?
         method (tree, state) state.node end,      // current key
         method (tree, state) state.node.data end, // current item
         method (new, tree, state) state.node.data := new end, // modify item
         identity)                                             // copy state
end;

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

define method main(argv0 :: <string>, #rest argv) => ()
  let prog = begin
               let last = 0;
               for (i from 0 below argv0.size)
                 if (argv0[i] = '/') last := i + 1 end
               end;
               copy-sequence(argv0, start: last)
             end;
  block ()
    select (argv.size)
      1 =>
        let t = parse-tree(argv[0]);
        let iter = iterator(t);
        loop (done)
          let (any?, item) = iter();
          unless (any?) done(#f) end;
          write-element(*standard-output*, item);
        end;
        new-line(*standard-output*);
      2 =>
        let ta = parse-tree(argv[0]);
        let tb = parse-tree(argv[1]);
        format(*standard-output*, "%s\n",
               if (same-collections?(ta, tb)) "match" else "no match" end);
      otherwise
        error("bad args");
    end
  exception (cond :: <error>)
    format(*standard-error*, "%s: %s\n", prog, cond);
    exit(exit-code: 1)
  end
end

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