chiark - git - mdw - fringe/blob - smalltalk-fringe.st

   1 "-*-smalltalk-*-
   2
   3 Smalltalk implementation of a `same-fringe' solver.
   4
   5 Use GNU Smalltalk syntax -- it seems more Emacs-friendly.
   6 "
   7
   8 Object subclass: Node [
   9     | left right data |
  10
  11     <comment: 'I represent simple binary tree nodes.  My instances consist of
  12 a data object, and left and right subtrees.  The leaves of a tree are
  13 instances of LeafNode.'>
  14     <category: 'Toys-SameFringe'>
  15
  16     Node class >> left: aNode data: anObject right: anotherNode [
  17         "Answer a newly tree Node with the given subtrees and data."
  18
  19         <category: 'instance creation'>
  20         ^self new left: aNode data: anObject right: anotherNode
  21     ]
  22
  23     Node class >> parse: aString [
  24         "Answer a newly constructed tree, parsed from aString."
  25
  26         <category: 'parsing'>
  27         | stream tree |
  28         stream := ReadStream on: aString.
  29         tree := stream parseTree.
  30         stream atEnd ifFalse: [self error: 'trailing junk'].
  31         ^tree
  32     ]
  33
  34     left: aNode data: anObject right: anotherNode [
  35         "Initialize a (presumably) new instance."
  36
  37         <category: 'initialization'>
  38         left := aNode.
  39         right := anotherNode.
  40         data := anObject.
  41         ^self
  42     ]
  43
  44     left [
  45         "Answer the receiver's left subtree."
  46
  47         <category: 'accessing'>
  48         ^left
  49     ]
  50
  51     right [
  52         "Answer the receiver's right subtree."
  53
  54         <category: 'accessing'>
  55         ^right
  56     ]
  57
  58     data [
  59         "Answer the receiver's data."
  60
  61         <category: 'accessing'>
  62         ^data
  63     ]
  64
  65     isLeaf [
  66         "Answer false, becase the receiver is not a leaf."
  67
  68         <category: 'testing'>
  69         ^false
  70     ]
  71
  72     iterator [
  73         "Answer a new iterator to walk this node."
  74
  75         <category: 'iteration'>
  76         ^NodeIterator for: self
  77     ]
  78
  79     inorderTell: aBlock tell: aNodeIterator [
  80         "This is the hairy part of the iteration protocol.
  81
  82          The algorithm works like this.  We're meant to wander as far down
  83          the left of the tree as we can; once we're there, we call
  84          aNodeIterator with the data we found and a block which will continue
  85          the iteration over the rest of the tree and finally invoke aBlock.
  86
  87          Observe that there are no explicit conditionals here.  It's all done
  88          with object dispatch.  And smoke.  And mirrors.
  89
  90          Also note that this is tail-recursive.  The `stack' is built up in
  91          the hairy block constructions, which all go on the heap."
  92
  93         <category: 'private iteration'>
  94         left
  95             inorderTell:
  96                 [aNodeIterator
  97                     found: data
  98                     then: [right inorderTell: aBlock tell: aNodeIterator]]
  99             tell: aNodeIterator
 100     ]
 101
 102     sameFringeAs: aNode [
 103         "Answer whether traversing the receiver inorder yields the same
 104          objects as traversing aNode."
 105
 106         <category: 'comparison'>
 107         | ia ib |
 108         ia := self iterator.
 109         ib := aNode iterator.
 110         [ia atEnd] whileFalse:
 111             [ib atEnd ifTrue: [^false].
 112              (ia next = ib next) ifFalse: [^false]].
 113         ^ib atEnd
 114     ]
 115
 116     displayOn: aStream [
 117         "Write a simple representation of self to the stream."
 118
 119         <category: 'printing'>
 120         aStream nextPut: $(;
 121             display: left;
 122             display: data;
 123             display: right;
 124             nextPut: $)
 125     ]
 126
 127     Node class >> main: anArray [
 128         "Noddy script main program."
 129
 130         <category: 'command line'>
 131         [(Dictionary new
 132             at: 1 put:
 133                 [(self parse: (anArray at: 1)) iterator do:
 134                      [:char | FileStream stdout nextPut: char].
 135                   FileStream stdout nl];
 136             at: 2 put:
 137                 [FileStream stdout display:
 138                      (((self parse: (anArray at: 1))
 139                           sameFringeAs: (self parse: (anArray at: 2)))
 140                               ifTrue: ['match']
 141                               ifFalse: ['no match']);
 142                       nl ];
 143             at: anArray size ifAbsent: [self error: 'bad args'])
 144             value]
 145         on: Error do:
 146             [:error |
 147                 FileStream stderr
 148                     nextPutAll: 'smalltalk-fringe: ';
 149                     nextPutAll: error messageText;
 150                     nl.
 151                 ^1].
 152         ^0
 153     ]
 154 ]
 155
 156 PositionableStream extend [
 157     parseTree [
 158         "Answer a newly constructed tree, parsed from the receiver.
 159
 160          The syntax is very simple:
 161
 162                 tree ::= empty | `(' tree char tree `)'
 163
 164          where char is any character.  Ambiguity is resolved by deciding that
 165          something beginning with `(' where a tree is expected really is a
 166          tree and not an empty tree followed by the char `('."
 167
 168         <category: 'parsing'>
 169         | left data right |
 170
 171         self peek = $( ifFalse: [^LeafNode instance].
 172         self next.
 173         left := self parseTree.
 174         self atEnd ifTrue: [self error: 'no data'].
 175         data := self next.
 176         right := self parseTree.
 177         self next = $) ifFalse: [self error: 'missing )'].
 178         ^Node left: left data: data right: right
 179     ]
 180 ]
 181
 182 Object subclass: LeafNode [
 183     <comment: 'I represent the leaves of a tree of Nodes.  I don''t hold any
 184 kind of interesting state.  My methods provide the base cases for some of the
 185 recursive protocols used to handle Nodes.'>
 186     <category: 'Toys-SameFringe'>
 187
 188     instance := LeafNode new.
 189
 190     displayOn: aStream [
 191         "Write a simple representation of self to the stream."
 192
 193         <category: 'printing'>
 194         "Nothing to do!"
 195     ]
 196
 197     isLeaf [
 198         "Answer true, because the receiver is a leaf node."
 199
 200         <category: 'testing'>
 201         ^true
 202     ]
 203
 204     iterator [
 205         "Return a new iterator to walk this node."
 206
 207         <category: 'iteration'>
 208         ^NodeIterator for: self
 209     ]
 210
 211     inorderTell: aBlock tell: aNodeIterator [
 212         "This is the hairy part of the iteration protocol.
 213
 214          But in this case it's simple.  We've overshot the end, so we just
 215          need to call aBlock to persuade our parent to announce itself to the
 216          iterator."
 217
 218         <category: 'private iteration'>
 219         aBlock value
 220     ]
 221
 222     LeafNode class >> instance [
 223         "Return the unique instance of the leaf node."
 224
 225         <category: 'singleton'>
 226         ^instance
 227     ]
 228 ]
 229
 230 Stream subclass: NodeIterator [
 231     | item rest |
 232
 233     <comment: 'I hold the state for external iteration of trees of Nodes and
 234 (halfheartedly) implement the Stream protocol.'>
 235     <category: 'Toys-SameFringe'>
 236
 237     found: anObject then: aBlock [
 238         "Stash the newly found item from the hairy iteration protocol.
 239
 240          When the iteration protocol decides on the next leftmost item to
 241          return, it gives us anObject that it found, and aBlock which will
 242          continue until it finds the next object."
 243
 244         <category: 'private iteration'>
 245         item := anObject.
 246         rest := aBlock.
 247     ]
 248
 249     NodeIterator class >> for: aNode [
 250         "Answer a new iterator for the tree starting at aNode."
 251
 252         <category: 'instance creation'>
 253         ^self new walk: aNode
 254     ]
 255
 256     walk: aNode [
 257         "Start walking a subtree starting at aNode.
 258
 259          We get the node to iterate itself and finally tell us that it's
 260          finished."
 261
 262         <category: 'initialization'>
 263         aNode inorderTell: [rest := nil] tell: self
 264     ]
 265
 266     next [
 267         "Answer the next element from the tree, or nil if we've hit the end."
 268
 269         <category: 'reading'>
 270         | it |
 271         rest ifNil: [^nil].
 272         it := item.
 273         rest value.
 274         ^it
 275     ]
 276
 277     peek [
 278         "Answer the next element without removing it."
 279
 280         <category: 'reading'>
 281         rest ifNil: [^nil] ifNotNil: [^item]
 282     ]
 283
 284     atEnd [
 285         "Answer whether we have reached the end of the iteration."
 286
 287         <category: 'testing'>
 288         ^rest isNil
 289     ]
 290 ]