4 copyright: (c) 2010 Mark Wooding
8 * Dylan implementation of a `same-fringe' solver.
11 ///--------------------------------------------------------------------------
15 // loop (ESCAPE) BODY end [loop]
17 // Repeatedly evaluate the BODY, with ESCAPE bound to a procedure which
18 // causes the loop to end immediately and yield its argument.
20 { loop (?escape:variable) ?:body end }
21 => { block (?escape) while (#t) ?body end end }
24 ///--------------------------------------------------------------------------
27 // We specialize methods on trees, whether leaves or non-leaves, so we need a
29 define abstract class <tree> (<collection>) end;
31 // A leaf is an empty tree. We don't use #f because we need to specialize
32 // methods on empty trees too. We only need one leaf, but there's no point
33 // in being petty about it.
34 define class <leaf> (<tree>) end;
35 define constant $leaf = make(<leaf>);
37 // A node is a tree which carries data and has subtrees.
38 define class <node> (<tree>)
39 constant slot left :: <tree>, required-init-keyword: left:;
40 constant slot right :: <tree>, required-init-keyword: right:;
41 slot data, init-keyword: data:, init-value: #f;
44 // Use method dispatch to decide whether a tree is a leaf.
45 define generic leaf?(tree) => (p :: <boolean>);
46 define method leaf?(tree :: <leaf>) => (p :: <boolean>) #t end;
47 define method leaf?(tree :: <node>) => (p :: <boolean>) #f end;
49 define method parse-tree
51 #key start :: <integer> = 0,
52 end: stop :: <integer> = string.size)
54 // Parse STRING, and return the tree described.
56 // The syntax is simple:
58 // tree ::= empty | `(' tree char tree `)'
60 // The ambigity is resolved by always treating `(' as a tree when a tree is
63 local method parse(i :: <integer>) => (tree :: <tree>, i :: <integer>)
64 if (i >= stop | string[i] ~= '(')
67 let (left, i) = parse(i + 1);
68 if (i >= stop) error("no data") end;
70 let (right, i) = parse(i + 1);
71 if (i >= stop | string[i] ~= ')') error("missing )") end;
72 values(make(<node>, left: left, right: right, data: data), i + 1)
75 let (tree, i) = parse(start);
76 if (i ~= stop) error("trailing junk") end;
80 define method print-object(tree :: <tree>, stream :: <stream>) => ()
81 // Print a TREE to the given STREAM. No newline is printed.
83 local method recur(tree)
87 write-element(stream, tree.data);
95 ///--------------------------------------------------------------------------
96 /// Iteration utilities.
98 define method iterator(coll :: <collection>) => (iter :: <function>)
99 // Return a function which iterates over the collection COLL.
101 // Each call to the function returns two values: ANY? is false if the
102 // collection is exhausted, or true if a new item was returned; and ITEM is
103 // the item from the collection. Obviously, ITEM is meaningful only if
106 let (state, final, next, finished?, key, item, item-setter, copy) =
107 forward-iteration-protocol(coll);
108 method () => (any? :: <boolean>, item :: <object>)
109 if (finished?(coll, state, final))
112 let this = item(coll, state);
113 state := next(coll, state);
119 define method same-collections?
120 (coll-a :: <collection>, coll-b :: <collection>) => (p :: <boolean>)
121 // Answer whether COLL-A and COLL-B contain the same elements (according to
122 // `=') in the same order.
124 let iter-a = iterator(coll-a);
125 let iter-b = iterator(coll-b);
127 let (any-a, item-a) = iter-a();
128 let (any-b, item-b) = iter-b();
130 any-a ~= any-b => done(#f);
132 item-a ~= item-b => done(#f);
137 ///--------------------------------------------------------------------------
138 /// Fringe iteration.
140 define class <tree-iteration-state> (<object>)
141 // The iteration state for a tree. We remember the current node, and a
142 // closure which will produce the rest of the iteration. Iteration states
145 constant slot node :: <tree>, required-init-keyword: node:;
146 constant slot next :: <function>, required-init-keyword: next:;
149 define method forward-iteration-protocol(tree :: <tree>)
151 next :: <function>, finished? :: <function>,
152 this-key :: <function>,
153 this-item :: <function>, this-item-setter :: <function>,
155 // Iteration protocol implementation for the fringe of a binary tree.
157 local method iter(tree, after)
163 make(<tree-iteration-state>,
165 next: method () iter(tree.right, after) end)
170 values(iter(tree, method () #f end), // initial state
172 method (tree, state) state.next() end, // next state
173 method (tree, state, limit) ~ state end, // finished?
174 method (tree, state) state.node end, // current key
175 method (tree, state) state.node.data end, // current item
176 method (new, tree, state) state.node.data := new end, // modify item
177 identity) // copy state
180 ///--------------------------------------------------------------------------
183 define method main(argv0 :: <string>, #rest argv) => ()
186 for (i from 0 below argv0.size)
187 if (argv0[i] = '/') last := i + 1 end
189 copy-sequence(argv0, start: last)
194 let t = parse-tree(argv[0]);
195 let iter = iterator(t);
197 let (any?, item) = iter();
198 unless (any?) done(#f) end;
199 write-element(*standard-output*, item);
201 new-line(*standard-output*);
203 let ta = parse-tree(argv[0]);
204 let tb = parse-tree(argv[1]);
205 format(*standard-output*, "%s\n",
206 if (same-collections?(ta, tb)) "match" else "no match" end);
210 exception (cond :: <error>)
211 format(*standard-error*, "%s: %s\n", prog, cond);
216 ///----- That's all, folks --------------------------------------------------