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