Commit | Line | Data |
---|---|---|
5c4e9900 MW |
1 | module: dylan-fringe |
2 | language: infix-dylan | |
3 | author: Mark Wooding | |
4 | copyright: (c) 2010 Mark Wooding | |
5 | ||
6 | /* -*-dylan-*- | |
7 | * | |
8 | * Dylan implementation of a `same-fringe' solver. | |
9 | */ | |
10 | ||
11 | ///-------------------------------------------------------------------------- | |
12 | /// Utilities. | |
13 | ||
14 | define macro loop | |
15 | // loop (ESCAPE) BODY end [loop] | |
16 | // | |
17 | // Repeatedly evaluate the BODY, with ESCAPE bound to a procedure which | |
18 | // causes the loop to end immediately and yield its argument. | |
19 | ||
20 | { loop (?escape:variable) ?:body end } | |
21 | => { block (?escape) while (#t) ?body end end } | |
22 | end; | |
23 | ||
24 | ///-------------------------------------------------------------------------- | |
25 | /// Nodes and trees. | |
26 | ||
27 | // We specialize methods on trees, whether leaves or non-leaves, so we need a | |
28 | // common superclass. | |
29 | define abstract class <tree> (<collection>) end; | |
30 | ||
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>); | |
36 | ||
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; | |
42 | end; | |
43 | ||
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; | |
48 | ||
49 | define method parse-tree | |
50 | (string :: <string>, | |
51 | #key start :: <integer> = 0, | |
52 | end: stop :: <integer> = string.size) | |
53 | => (tree :: <tree>) | |
54 | // Parse STRING, and return the tree described. | |
55 | // | |
56 | // The syntax is simple: | |
57 | // | |
58 | // tree ::= empty | `(' tree char tree `)' | |
59 | // | |
60 | // The ambigity is resolved by always treating `(' as a tree when a tree is | |
61 | // expected. | |
62 | ||
63 | local method parse(i :: <integer>) => (tree :: <tree>, i :: <integer>) | |
64 | if (i >= stop | string[i] ~= '(') | |
65 | values($leaf, i) | |
66 | else | |
67 | let (left, i) = parse(i + 1); | |
68 | if (i >= stop) error("no data") end; | |
69 | let data = string[i]; | |
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) | |
73 | end | |
74 | end; | |
75 | let (tree, i) = parse(start); | |
76 | if (i ~= stop) error("trailing junk") end; | |
77 | tree | |
78 | end; | |
79 | ||
80 | define method print-object(tree :: <tree>, stream :: <stream>) => () | |
81 | // Print a TREE to the given STREAM. No newline is printed. | |
82 | ||
83 | local method recur(tree) | |
84 | unless (tree.leaf?) | |
85 | write(stream, "("); | |
86 | recur(tree.left); | |
87 | write-element(stream, tree.data); | |
88 | recur(tree.right); | |
89 | write(stream, ")"); | |
90 | end | |
91 | end; | |
92 | recur(tree) | |
93 | end; | |
94 | ||
95 | ///-------------------------------------------------------------------------- | |
96 | /// Iteration utilities. | |
97 | ||
98 | define method iterator(coll :: <collection>) => (iter :: <function>) | |
99 | // Return a function which iterates over the collection COLL. | |
100 | // | |
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 | |
104 | // ANY? is true. | |
105 | ||
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)) | |
110 | values(#f, #f) | |
111 | else | |
112 | let this = item(coll, state); | |
113 | state := next(coll, state); | |
114 | values(#t, this) | |
115 | end | |
116 | end | |
117 | end; | |
118 | ||
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. | |
123 | ||
124 | let iter-a = iterator(coll-a); | |
125 | let iter-b = iterator(coll-b); | |
126 | loop (done) | |
127 | let (any-a, item-a) = iter-a(); | |
128 | let (any-b, item-b) = iter-b(); | |
129 | case | |
130 | any-a ~= any-b => done(#f); | |
131 | ~ any-a => done(#t); | |
132 | item-a ~= item-b => done(#f); | |
133 | end | |
134 | end | |
135 | end; | |
136 | ||
137 | ///-------------------------------------------------------------------------- | |
138 | /// Fringe iteration. | |
139 | ||
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 | |
143 | // are immutable. | |
144 | ||
145 | constant slot node :: <tree>, required-init-keyword: node:; | |
146 | constant slot next :: <function>, required-init-keyword: next:; | |
147 | end; | |
148 | ||
149 | define method forward-iteration-protocol(tree :: <tree>) | |
150 | => (state, final, | |
151 | next :: <function>, finished? :: <function>, | |
152 | this-key :: <function>, | |
153 | this-item :: <function>, this-item-setter :: <function>, | |
154 | copy :: <function>) | |
155 | // Iteration protocol implementation for the fringe of a binary tree. | |
156 | ||
157 | local method iter(tree, after) | |
158 | if (tree.leaf?) | |
159 | after() | |
160 | else | |
161 | iter(tree.left, | |
162 | method () | |
163 | make(<tree-iteration-state>, | |
164 | node: tree, | |
165 | next: method () iter(tree.right, after) end) | |
166 | end) | |
167 | end | |
168 | end; | |
169 | ||
170 | values(iter(tree, method () #f end), // initial state | |
171 | #f, // final 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 | |
178 | end; | |
179 | ||
180 | ///-------------------------------------------------------------------------- | |
181 | /// Main program. | |
182 | ||
183 | define method main(argv0 :: <string>, #rest argv) => () | |
184 | let prog = begin | |
185 | let last = 0; | |
186 | for (i from 0 below argv0.size) | |
187 | if (argv0[i] = '/') last := i + 1 end | |
188 | end; | |
189 | copy-sequence(argv0, start: last) | |
190 | end; | |
191 | block () | |
192 | select (argv.size) | |
193 | 1 => | |
194 | let t = parse-tree(argv[0]); | |
195 | let iter = iterator(t); | |
196 | loop (done) | |
197 | let (any?, item) = iter(); | |
198 | unless (any?) done(#f) end; | |
199 | write-element(*standard-output*, item); | |
200 | end; | |
201 | new-line(*standard-output*); | |
202 | 2 => | |
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); | |
207 | otherwise | |
208 | error("bad args"); | |
209 | end | |
210 | exception (cond :: <error>) | |
211 | format(*standard-error*, "%s: %s\n", prog, cond); | |
212 | exit(exit-code: 1) | |
213 | end | |
214 | end | |
215 | ||
216 | ///----- That's all, folks -------------------------------------------------- |