cowan@marob.masa.com (John Cowan) (07/27/90)
!LinkedSet class methods !
new
"Answer a new LinkedSet."
^(self basicNew) setContents: Set new!
quickNew
"Returns a new LinkedCollection that has a
Bag inside for fast lookup of entries."
^self new! !
!LinkedSet methods !
hookAdd: aLink
"Private - Verify that the value doesn't already exist.
If it does, answer true without doing anything."
(contents includes: aLink value)
ifTrue: [^true].
^super hookAdd: aLink! !
LinkedCollection subclass: #SortedLinkedCollection
instanceVariableNames:
'sortBlock '
classVariableNames: ''
poolDictionaries: '' !
!SortedLinkedCollection class methods !
new
"Answer a new SortedLinkedCollection which will
sort elements in ascending order."
^self sortBlock: [:a :b | a <= b]!
quickNew
"Answer a new SortedLinkedCollection with
support for fast lookup."
^self new setContents: Bag new.!
quickSortBlock: aBlock
"Answer a new SortedLinkedCollection which will
sort elements as determined by sortBlock,
with support for fast lookup."
^(super new) basicSortBlock: aBlock;
setContents: Bag new!
sortBlock: aBlock
"Answer a new SortedLinkedCollection which will
sort elements as determined by sortBlock"
^(super new) basicSortBlock: aBlock! !
!SortedLinkedCollection methods !
add: anObject
"Answer anObject. Add anObject to the
receiver in sorted position."
| newLink |
newLink := Link value: anObject.
(self hookAdd: newLink) ifTrue: [^anObject].
self linksDo: [:oldLink |
(sortBlock value: anObject value: oldLink value)
"newLink should precede oldLink"
ifTrue: [(newLink addBefore: oldLink)
ifTrue: [startPosition := newLink].
^anObject]].
(newLink addAfter: endPosition)
ifTrue: [endPosition := newLink].
^anObject!
add: newObject after: oldObject
"Illegal because sortBlock determines order."
self invalidMessage!
add: newObject afterIndex: anInteger
"Illegal because sortBlock determines order."
self invalidMessage!
add: newObject before: oldObject
"Illegal because sortBlock determines order."
self invalidMessage!
add: newObject beforeIndex: anInteger
"Illegal because sortBlock determines order."
self invalidMessage!
at: anIndex put: anObject
"Illegal because sortBlock determines order."
self invalidMessage!
basicSortBlock: aBlock
"Private - Change the sort block without resorting."
sortBlock := aBlock!
consistent
"Answer true if all links are in order and sort
order is correct."
| nextLink |
super consistent
ifFalse: [^false].
self linksDo: [:link |
nextLink := link after.
nextLink isNil ifTrue: [^true].
(sortBlock value: link value value: nextLink value)
ifFalse: [^false]]!
emptyCopy
"Answer an empty SortedLinkedCollection with the
same sort block as the receiver."
| answer |
answer := super emptyCopy.
answer basicSortBlock: sortBlock.
^answer!
reSort
"Resort receiver according to sortBlock."
| answer |
answer := self emptyCopy.
self do: [:obj | answer add: obj].
self become: answer!
sortBlock
"Answer the block that determines sort
ordering for the receiver."
^sortBlock!
sortBlock: aBlock
"Answer the receiver. Set the sort block for
the receiver to aBlock and resort the receiver."
self basicSortBlock: aBlock.
self reSort! !
SortedLinkedCollection subclass: #SortedLinkedSet
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: '' !
!SortedLinkedSet class methods !
new
"Answer a new SortedLinkedSet."
^(self new) setContents: Set new!
quickNew
"Answer a new SortedLinkedCollection with
support for fast lookup."
^self new!
quickSortBlock: aBlock
"Answer a new SortedLinkedCollection which will
sort elements as determined by sortBlock,
with support for fast lookup."
^self sortBlock: aBlock!
sortBlock: aBlock
"Answer a new SortedLinkedSet which will
sort elements as determined by sortBlock."
^super sortBlock: aBlock;
setContents: Set new! !
!SortedLinkedSet methods !
hookAdd: aLink
"Private - Verify that the value doesn't already exist.
If it does, answer true without doing anything."
(contents includes: aLink value)
ifTrue: [^true].
^super hookAdd: aLink! !
Array variableSubclass: #RectArray
instanceVariableNames:
'shape '
classVariableNames: ''
poolDictionaries: '' !
!RectArray class methods !
canonicalize: aShape
"Private - Answer a Shape in canonical format.
All Array elements are converted to Intervals,
and all Integer elements are converted to
degenerate Intervals."
| answer n |
answer := aShape copy.
1 to: aShape size do: [:i |
n := aShape at: i.
(n isKindOf: Integer) ifTrue:
[answer at: i put: (n to: n - 1)].
(n isKindOf: Array) ifTrue:
[answer at: i put: ((n at: 1) to: (n at: 2))]].
^answer!
contents: aCollection
"Answer a one-dimensional RectArray
with contents aCollection."
^self shape: (Array with: (1 to: aCollection size))
contents: aCollection!
new
"Create a RectArray with empty shape.
This object has one element."
^(super new: 1) shape: #()!
new: aShape
"Answer a new RectArray with shape aShape."
| shape |
shape := self canonicalize: aShape.
^(super new: (self volume: shape)) shape: shape!
shape: aShape contents: aCollection
"Answer a new RectArray with shape aShape
and contents aCollection. Contents must be
specified in row major order."
| answer |
answer := self new: aShape.
1 to: answer size do: [:i |
answer at: i put: (aCollection at: i)].
^answer!
shape: aShape withAll: anObject
"Answer a new RectArray with shape aShape.
Every element is set to anObject."
| answer |
answer := self new: aShape.
answer atAllPut: anObject.
^answer!
volume: aShape
"Answer the volume specified by aShape."
| total |
total := 1.
aShape do: [:interval |
total := total *
(interval last - interval first + 1)].
^total!
with: anObject
"Answer a zero-dimensional RectArray containing
anObject as its sole element."
^self shape: #() withAll: anObject!
with: anObject1 with: anObject2
"Not appropriate for RectArrays (no shape)."
^self invalidMessage!
with: anObject1 with: anObject2 with: anObject3
"Not appropriate for RectArrays (no shape)."
^self invalidMessage!
with: anObject1 with: anObject2 with: anObject3 with: anObject4
"Not appropriate for RectArrays (no shape)."
^self invalidMessage! !
!RectArray methods !
apply: aSelector
"Answer a RectArray with the same shape as
the receiver, resulting from applying aSelector
to every element of the receiver."
| answer |
answer := RectArray new: shape.
1 to: self size do: [ :i |
answer at: i put: ((self at: i) perform: aSelector)].
^answer!
apply: aSelector with: aRectArray
"Answer a RectArray with the same shape as
the receiver, resulting from applying aSelector
to every element of the receiver and every
element of aRectArray."
| answer |
shape = aRectArray shape ifFalse:
[^self error: 'Arrays do not conform'].
answer := RectArray new: shape.
1 to: self size do: [ :i |
answer at: i put: ((self at: i) perform: aSelector
with: (aRectArray at: i))].
^answer!
at: anIndex
"Answer the element specified by anIndex,
which must be an Array of Integers or else
a single Integer."
^super at: (self rawIndex: anIndex)!
at: anIndex put: anObject
"Set self at: index to anObject."
^super at: (self rawIndex: anIndex) put: anObject!
click: anOdometer
"Private - Update anOdometer to access the next location
of the receiver."
^self click: anOdometer inShape: shape!
click: anOdometer inShape: aShape
"Private - Update anOdometer to access the next location
of the slice specified by aShape."
| index |
shape size to: 1 by: -1 do: [:n |
index := (anOdometer at: n) + 1.
index <= (aShape at: n) last ifTrue:
[anOdometer at: n put: index.
^anOdometer]
ifFalse:
[anOdometer at: n put: (aShape at: n) first]].
anOdometer become: 'overflow' copy.
^anOdometer.!
dimension: aDimension
"Answer an interval corresponding to the
possible values of aDimension."
^shape at: aDimension!
lowerBound: aDimension
"Answer the lower bound of aDimension
for the receiver."
^(shape at: aDimension) first!
nonDegenerate: aShape
"Private - Return a new shape with all degenerate
intervals removed from it."
| answer |
answer := OrderedCollection new: aShape size.
aShape do: [:intv |
(intv first <= intv last) ifTrue:
[answer add: intv]].
^answer asArray!
odometer
"Private - Return an odometer initialized to the beginning
of the shape of receiver."
^self odometer: shape!
odometer: aShape
"Private - Return an odometer initialized to the beginning
of aShape."
| answer |
answer := Array new: aShape size.
1 to: aShape size do: [:i |
answer at: i put: (aShape at: i) first].
^answer!
outerProduct: aSelector with: aRectArray
"Compute the outer product of the receiver and
aRectArray using the operator aSelector.
Answer a new RectArray."
| answer selfOdometer otherOdometer answerOdometer |
answer := RectArray new: shape, aRectArray shape.
answerOdometer := answer odometer.
selfOdometer := self odometer.
[self validOdometer: selfOdometer] whileTrue:
[otherOdometer := aRectArray odometer.
[self validOdometer: otherOdometer] whileTrue:
[answer at: answerOdometer put:
((self at: selfOdometer) perform: aSelector
with: (aRectArray at: otherOdometer)).
answer click: answerOdometer.
aRectArray click: otherOdometer].
self click: selfOdometer].
^answer!
printOn: aStream
"Print a representation of the receiver on aStream,
using nested parentheses. Zero-dimensional
arrays are printed with just the datum."
| odometer |
shape size = 0 ifTrue:
[(self at: 1) printOn: aStream]
ifFalse:
[odometer := self odometer.
self printOn: aStream dimension: 1
withOdometer: odometer]!
printOn: aStream dimension: dimension
withOdometer: odometer
"Private - Recursive printing routine."
dimension > shape size ifTrue:
[(self at: odometer) printOn: aStream.
aStream nextPut: $ ]
ifFalse:
[aStream nextPut: $(.
odometer at: dimension
put: (shape at: dimension) first.
[(odometer at: dimension) <=
(shape at: dimension) last] whileTrue:
[self printOn: aStream dimension: dimension + 1
withOdometer: odometer.
odometer at: dimension
put: (odometer at: dimension) + 1].
aStream nextPut: $)]!
range: aDimension
"Answer the number of elements in aDimension
of the receiver."
| interval |
interval := shape at: aDimension.
^interval last - interval first + 1.!
rank
"Answer the rank (number of dimensions)
of the receiver."
^shape size!
rawIndex: anIndex
"Private - Answer physical index from anIndex,
an index array. If anIndex is a number, answer it."
| result index |
(anIndex isKindOf: Integer) ifTrue: [^anIndex].
anIndex size = shape size ifFalse:
[^self errorInBounds: anIndex].
result := 0.
1 to: anIndex size do: [:i |
index := anIndex at: i.
((shape at: i) includes: index) ifFalse:
[^self errorInBounds: anIndex].
result := (result * (self range: i)) + index -
(shape at: i) first].
^result + 1!
reversed: aDimension
"Answer a copy of the receiver reversed along
aDimension."
| intv sum |
intv := shape at: aDimension.
sum := intv first + intv last.
^self transform: [ :odometer |
(odometer copy) at: aDimension put:
sum - (odometer at: aDimension); yourself]!
rotated: aDimension by: anInteger
"Answer a copy of the receiver rotated along
aDimension by anInteger positions."
| intv base diff value |
intv := shape at: aDimension.
base := intv first.
diff := intv last - base + 1.
^self transform: [ :odometer |
value := odometer at: aDimension.
value := (((value - base) - anInteger) \\ diff) + base.
(odometer copy) at: aDimension put: value;
yourself]!
shape
"Return the shape of the receiver."
^shape!
shape: aShape
"Reshape receiver. Answer receiver."
(shape notNil and:
[(self class volume: aShape) ~= self size]) ifTrue:
[^self error: 'Can''t resize RectArrays'].
shape := self class canonicalize: aShape.!
slice: aSlice
"Answer a new RectArray which represents the
slice of the receiver specified by aSlice.
Degenerate dimensions in aSlice are removed
from the answer."
| slice answer srcOdometer dstOdometer |
slice := RectArray canonicalize: aSlice.
(self validSlice: slice) ifFalse:
[^self errorInBounds].
answer := RectArray new:
(self nonDegenerate: slice).
srcOdometer := self odometer: slice.
dstOdometer := answer odometer.
[self validOdometer: srcOdometer] whileTrue:
[answer at: dstOdometer put:
(self at: srcOdometer).
self click: srcOdometer inShape: slice.
answer click: dstOdometer].
^answer!
transform: aBlock
"Private - Answer a transformed copy of the receiver.
The receiver is iterated over using an odometer,
which is passed through aBlock before being
used to index the result."
| item answer oldOdometer newOdometer |
answer := RectArray new: shape.
oldOdometer := self odometer.
[self validOdometer: oldOdometer] whileTrue:
[item := self at: oldOdometer.
newOdometer := aBlock value: oldOdometer.
answer at: newOdometer put: item.
self click: oldOdometer].
^answer!
transposed
"Answer a copy of the receiver transposed."
^self transform: [ :odometer |
odometer reversed]!
transposed: aCollection
"Answer a copy of the receiver transposed.
aCollection specifies the new order
of dimensions to be used."
| newOdometer |
newOdometer := Array new: shape size.
^self transform: [ :odometer |
1 to: odometer size do: [ :i |
newOdometer at: i put:
(odometer at: (aCollection at: i))].
newOdometer]!
upperBound: aDimension
"Answer the upper bound of aDimension
for the receiver."
^(shape at: aDimension) last!
validOdometer: anOdometer
"Private - Answer true if anOdometer has not overflowed.
Not a general validity test."
^anOdometer ~= 'overflow'!
validSlice: aSlice
"Private - Generate an error if aSlice is not a valid slice
of the receiver. Answer aSlice otherwise."
aSlice size = shape size ifFalse:
[^false].
shape with: aSlice do: [:shintv :slintv |
slintv size == 0 ifFalse:
[slintv first < shintv first ifTrue:
[^false].
slintv last > shintv last ifTrue:
[^false]]].
^true.! !
Array variableSubclass: #SparseArray
instanceVariableNames:
'size default dict '
classVariableNames: ''
poolDictionaries: '' !
!SparseArray class methods !
new
"Answer a new SparseArray of size zero."
| temporaries |
^self new: 0 default: nil!
new: size
"Answer a new SparseArray of specified size,
initialized to nil."
^self new: size default: nil!
new: size withAll: default
"Answer a new SparseArray of specified size,
initialized to default."
^self basicNew size: size default: default! !
!SparseArray methods !
at: anIndex
"Answer the element of the receiver
stored at position anIndex."
self checkIndex: anIndex.
^dict at: anIndex ifAbsent: [default].!
at: anIndex put: anElement
"Put anElement into the receiver
at position anIndex. Answer anElement."
self checkIndex: anIndex.
anElement = default ifTrue:
[dict removeKey: anIndex ifAbsent: [nil]]
ifFalse:
[dict at: anIndex put: anElement].
^anElement!
atAllPut: anObject
"Answer the receiver after each element
has been replaced with anObject."
self size: size default: anObject!
copyWith: anObject
"Answer a copy of the receiver with
anObject added to it as an element."
^self shallowCopy growBy: 1; at: size + 1 put: anObject; yourself!
emptyCopy
"Answer a new SparseArray with the same default value
but no elements."
| answer |
^SparseArray new: size withAll: default!
emptyCopy: aSize
"Answer a new SparseArray of size aSize with the same default value
but no elements."
| answer |
^SparseArray new: aSize withAll: default!
grow
"Answer the receiver expanded in
size to accomodate more elements."
self growBy: self growSize!
growBy: anInteger
"Private - Increase size of object by anInteger."
size := size + anInteger!
includes: anObject
"Answer true if the receiver contains an
element equal to anObject, else answer false."
anObject = default ifTrue:
[^size ~= dict size]. "This is true if no default objects exist"
^dict includes: anObject!
occurrencesOf: anObject
"Answer the number of elements contained
in the receiver collection that are equal
to anObject."
anObject = default ifTrue:
[^size - dict size]
ifFalse:
[^dict occurrencesOf: anObject]!
size
"Answer the number of elements in the receiver."
^size!
size: aSize default: aDefault
"Private - Initialize receiver to have size aSize and
default aDefault."
size := aSize.
default := aDefault.
dict := IdentityDictionary new.! !
OrderedCollection subclass: #Tree
instanceVariableNames:
'parent value '
classVariableNames: ''
poolDictionaries: '' !
!Tree class methods !
value: anObject
"Answer a new Tree holding anObject with no parent."
^self value: anObject parent: nil!
value: anObject parent: aTree
"Answer a new Tree holding anObject, with parent aTree,
and with room for some children."
^super new value: anObject; parent: aTree! !
!Tree methods !
= aTree
"Trees are equal only if identical."
^self == aTree!
ancestorsDo: aBlock
"Visit all the ancestors of the receiver, parent-first.
aBlock is passed one argument, the Tree."
| ancestor |
ancestor := parent.
[ancestor notNil] whileTrue:
[aBlock value: ancestor.
ancestor := ancestor parent]!
bottomUp: aBlock depth: depth
"Visit the receiver and all its descendants, depth-first
and bottom-up. aBlock is invoked with two arguments,
the Tree and the depth."
self do: [:child |
child bottomUp: aBlock depth: depth + 1].
aBlock value: self value: depth.!
breadthFirst: aBlock
"Visit the receiver and all its descendants, breadth-first
and top-down. aBlock is invoked with one argument,
the Tree."
| queue |
queue := OrderedCollection new.
self topDown: [:tree :depth | queue add: tree] depth: 0.
queue do: [:tree | aBlock value: tree]!
consistent
"Answer true if the receiver is a child of its parent and
parents of all its children. Parent and children must
also be Trees, except that the parent may be nil."
parent notNil ifTrue:
[(parent isKindOf: Tree) ifFalse: [^false].
(parent includes: self) ifFalse: [^false]].
self do: [:child |
(child isKindOf: Tree) ifFalse: [^false].
child parent = self ifFalse: [^false]].
^true!
graft: aTree
"Change the receiver's parent to aTree. The receiver must
not be an ancestor of aTree."
aTree ancestorsDo: [:anc |
anc = self ifTrue:
[self error: 'Attempted graft loop']].
aTree notNil ifTrue:
[aTree add: self].
parent notNil ifTrue:
[parent remove: self].
parent := aTree!
isLeaf
"Answer true if receiver is a leaf (no children)"
^self isEmpty!
isRoot
"Answer true if receiver is a root (parent is nil)"
^parent isNil!
leftSibling
"Answer the Tree which appears just before the receiver
in the parent's list of children. Nil if no parent or no sibling."
| index |
parent isNil ifTrue: [^nil].
index := parent indexOf: self.
index < 2 ifTrue: [^nil].
^parent at: index - 1!
parent
"Answer the parent of the receiver."
^parent!
parent: aParent
"Set the parent of the receiver to aParent."
parent := aParent!
printOn: aStream
"Append the ASCII representation
of the receiver to aStream. Trees look like other
Collections, except that the value replaces the
word 'Tree' in the output."
| limit |
(RecursiveSet includes: self)
ifTrue: [^self printRecursionOn: aStream].
RecursiveSet add: self.
limit := aStream position + self printLimit.
self value printOn: aStream.
aStream nextPut: $(.
self do: [ :element |
(aStream position > limit)
ifTrue: [
'...etc...)' printOn: aStream.
RecursiveSet remove: self ifAbsent: [].
^self].
element printOn: aStream.
aStream space].
aStream nextPut: $).
RecursiveSet remove: self ifAbsent: []!
prune
"Remove receiver from its parent and give it a nil parent."
^self graft: nil!
rightSibling
"Answer the Tree which appears just after the receiver
in the parent's list of children. Nil if no parent or no sibling."
| index |
parent isNil ifTrue: [^nil].
index := parent indexOf: self.
index = 0 ifTrue: [^nil].
index = parent size ifTrue: [^nil].
^parent at: index + 1!
topDown: aBlock depth: depth
"Visit the receiver and all its descendants, depth-first
and top-down. aBlock is invoked with two arguments,
the Tree and the depth."
aBlock value: self value: depth.
self do: [:child |
child topDown: aBlock depth: depth + 1]!
value
"Answer the value of the receiver."
^value!
value: anObject
"Set the value of the receiver to anObject."
value := anObject! !
--
cowan@marob.masa.com (aka ...!hombre!marob!cowan)
e'osai ko sarji la lojban