chiark - git - mdw - fringe/blob - dylan-fringe.dylan

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