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