+"-*-smalltalk-*-
+
+Smalltalk implementation of a `same-fringe' solver.
+
+Use GNU Smalltalk syntax -- it seems more Emacs-friendly.
+"
+
+Object subclass: Node [
+ | left right data |
+
+ <comment: 'I represent simple binary tree nodes. My instances consist of
+a data object, and left and right subtrees. The leaves of a tree are
+instances of LeafNode.'>
+ <category: 'Toys-SameFringe'>
+
+ Node class >> left: aNode data: anObject right: anotherNode [
+ "Answer a newly tree Node with the given subtrees and data."
+
+ <category: 'instance creation'>
+ ^self new left: aNode data: anObject right: anotherNode
+ ]
+
+ Node class >> parse: aString [
+ "Answer a newly constructed tree, parsed from aString."
+
+ <category: 'parsing'>
+ | stream tree |
+ stream := ReadStream on: aString.
+ tree := stream parseTree.
+ stream atEnd ifFalse: [self error: 'trailing junk'].
+ ^tree
+ ]
+
+ left: aNode data: anObject right: anotherNode [
+ "Initialize a (presumably) new instance."
+
+ <category: 'initialization'>
+ left := aNode.
+ right := anotherNode.
+ data := anObject.
+ ^self
+ ]
+
+ left [
+ "Answer the receiver's left subtree."
+
+ <category: 'accessing'>
+ ^left
+ ]
+
+ right [
+ "Answer the receiver's right subtree."
+
+ <category: 'accessing'>
+ ^right
+ ]
+
+ data [
+ "Answer the receiver's data."
+
+ <category: 'accessing'>
+ ^data
+ ]
+
+ isLeaf [
+ "Answer false, becase the receiver is not a leaf."
+
+ <category: 'testing'>
+ ^false
+ ]
+
+ iterator [
+ "Answer a new iterator to walk this node."
+
+ <category: 'iteration'>
+ ^NodeIterator for: self
+ ]
+
+ inorderTell: aBlock tell: aNodeIterator [
+ "This is the hairy part of the iteration protocol.
+
+ The algorithm works like this. We're meant to wander as far down
+ the left of the tree as we can; once we're there, we call
+ aNodeIterator with the data we found and a block which will continue
+ the iteration over the rest of the tree and finally invoke aBlock.
+
+ Observe that there are no explicit conditionals here. It's all done
+ with object dispatch. And smoke. And mirrors.
+
+ Also note that this is tail-recursive. The `stack' is built up in
+ the hairy block constructions, which all go on the heap."
+
+ <category: 'private iteration'>
+ left
+ inorderTell:
+ [aNodeIterator
+ found: data
+ then: [right inorderTell: aBlock tell: aNodeIterator]]
+ tell: aNodeIterator
+ ]
+
+ sameFringeAs: aNode [
+ "Answer whether traversing the receiver inorder yields the same
+ objects as traversing aNode."
+
+ <category: 'comparison'>
+ | ia ib |
+ ia := self iterator.
+ ib := aNode iterator.
+ [ia atEnd] whileFalse:
+ [ib atEnd ifTrue: [^false].
+ (ia next = ib next) ifFalse: [^false]].
+ ^ib atEnd
+ ]
+
+ displayOn: aStream [
+ "Write a simple representation of self to the stream."
+
+ <category: 'printing'>
+ aStream nextPut: $(;
+ display: left;
+ display: data;
+ display: right;
+ nextPut: $)
+ ]
+
+ Node class >> main: anArray [
+ "Noddy script main program."
+
+ <category: 'command line'>
+ [(Dictionary new
+ at: 1 put:
+ [(self parse: (anArray at: 1)) iterator do:
+ [:char | FileStream stdout nextPut: char].
+ FileStream stdout nl];
+ at: 2 put:
+ [FileStream stdout display:
+ (((self parse: (anArray at: 1))
+ sameFringeAs: (self parse: (anArray at: 2)))
+ ifTrue: ['match']
+ ifFalse: ['no match']);
+ nl ];
+ at: anArray size ifAbsent: [self error: 'bad args'])
+ value]
+ on: Error do:
+ [:error |
+ FileStream stderr
+ nextPutAll: 'smalltalk-fringe: ';
+ nextPutAll: error messageText;
+ nl.
+ ^1].
+ ^0
+ ]
+]
+
+PositionableStream extend [
+ parseTree [
+ "Answer a newly constructed tree, parsed from the receiver.
+
+ The syntax is very simple:
+
+ tree ::= empty | `(' tree char tree `)'
+
+ where char is any character. Ambiguity is resolved by deciding that
+ something beginning with `(' where a tree is expected really is a
+ tree and not an empty tree followed by the char `('."
+
+ <category: 'parsing'>
+ | left data right |
+
+ self peek = $( ifFalse: [^LeafNode instance].
+ self next.
+ left := self parseTree.
+ self atEnd ifTrue: [self error: 'no data'].
+ data := self next.
+ right := self parseTree.
+ self next = $) ifFalse: [self error: 'missing )'].
+ ^Node left: left data: data right: right
+ ]
+]
+
+Object subclass: LeafNode [
+ <comment: 'I represent the leaves of a tree of Nodes. I don''t hold any
+kind of interesting state. My methods provide the base cases for some of the
+recursive protocols used to handle Nodes.'>
+ <category: 'Toys-SameFringe'>
+
+ instance := LeafNode new.
+
+ displayOn: aStream [
+ "Write a simple representation of self to the stream."
+
+ <category: 'printing'>
+ "Nothing to do!"
+ ]
+
+ isLeaf [
+ "Answer true, because the receiver is a leaf node."
+
+ <category: 'testing'>
+ ^true
+ ]
+
+ iterator [
+ "Return a new iterator to walk this node."
+
+ <category: 'iteration'>
+ ^NodeIterator for: self
+ ]
+
+ inorderTell: aBlock tell: aNodeIterator [
+ "This is the hairy part of the iteration protocol.
+
+ But in this case it's simple. We've overshot the end, so we just
+ need to call aBlock to persuade our parent to announce itself to the
+ iterator."
+
+ <category: 'private iteration'>
+ aBlock value
+ ]
+
+ LeafNode class >> instance [
+ "Return the unique instance of the leaf node."
+
+ <category: 'singleton'>
+ ^instance
+ ]
+]
+
+Stream subclass: NodeIterator [
+ | item rest |
+
+ <comment: 'I hold the state for external iteration of trees of Nodes and
+(halfheartedly) implement the Stream protocol.'>
+ <category: 'Toys-SameFringe'>
+
+ found: anObject then: aBlock [
+ "Stash the newly found item from the hairy iteration protocol.
+
+ When the iteration protocol decides on the next leftmost item to
+ return, it gives us anObject that it found, and aBlock which will
+ continue until it finds the next object."
+
+ <category: 'private iteration'>
+ item := anObject.
+ rest := aBlock.
+ ]
+
+ NodeIterator class >> for: aNode [
+ "Answer a new iterator for the tree starting at aNode."
+
+ <category: 'instance creation'>
+ ^self new walk: aNode
+ ]
+
+ walk: aNode [
+ "Start walking a subtree starting at aNode.
+
+ We get the node to iterate itself and finally tell us that it's
+ finished."
+
+ <category: 'initialization'>
+ aNode inorderTell: [rest := nil] tell: self
+ ]
+
+ next [
+ "Answer the next element from the tree, or nil if we've hit the end."
+
+ <category: 'reading'>
+ | it |
+ rest ifNil: [^nil].
+ it := item.
+ rest value.
+ ^it
+ ]
+
+ peek [
+ "Answer the next element without removing it."
+
+ <category: 'reading'>
+ rest ifNil: [^nil] ifNotNil: [^item]
+ ]
+
+ atEnd [
+ "Answer whether we have reached the end of the iteration."
+
+ <category: 'testing'>
+ ^rest isNil
+ ]
+]