+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 --------------------------------------------------
~mdw / fringe / commitdiff