Source file St_kernel.ml

(* generated from kernel/*.st by languages/smalltalk/dune *)
let files = [
("Definitions.st", {st|"The kernel's classes, the Blue Book's hierarchy (its part two), a
subset. St_boot reads these definitions before anything can run: it
makes every class and its metaclass from them, ties the knot at the top
(Object class superclass == Class, Metaclass class class == Metaclass),
then compiles the methods of the other files. The fields the virtual
machine reads -- a class's, a context's, a Character's value -- are in
the order St_class.mli and St_interp.mli say."!

nil subclass: #Object
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!

Object subclass: #Behavior
	instanceVariableNames: 'superclass methodDict format'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Classes'!

Behavior subclass: #ClassDescription
	instanceVariableNames: 'instanceVariables organization'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Classes'!

ClassDescription subclass: #Class
	instanceVariableNames: 'name category classPool comment'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Classes'!

ClassDescription subclass: #Metaclass
	instanceVariableNames: 'thisClass'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Classes'!

Object subclass: #UndefinedObject
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!

Object subclass: #Boolean
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!

Boolean subclass: #True
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!

Boolean subclass: #False
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!

Object subclass: #Association
	instanceVariableNames: 'key value'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!

Object subclass: #Message
	instanceVariableNames: 'selector arguments'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!

Object subclass: #Magnitude
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Numeric-Magnitudes'!

Magnitude subclass: #Character
	instanceVariableNames: 'value'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Numeric-Magnitudes'!

Magnitude subclass: #Number
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Numeric-Numbers'!

Number subclass: #Integer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Numeric-Numbers'!

Integer subclass: #SmallInteger
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Numeric-Numbers'!

Integer variableByteSubclass: #LargePositiveInteger
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Numeric-Numbers'!

LargePositiveInteger variableByteSubclass: #LargeNegativeInteger
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Numeric-Numbers'!

Number subclass: #Float
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Numeric-Numbers'!

Number subclass: #Fraction
	instanceVariableNames: 'numerator denominator'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Numeric-Numbers'!

Object subclass: #Point
	instanceVariableNames: 'x y'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Primitives'!

Object subclass: #Rectangle
	instanceVariableNames: 'origin corner'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Primitives'!

Object subclass: #Collection
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Abstract'!

Collection subclass: #SequenceableCollection
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Abstract'!

SequenceableCollection subclass: #ArrayedCollection
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Abstract'!

ArrayedCollection variableSubclass: #Array
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Arrayed'!

ArrayedCollection variableByteSubclass: #String
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!

String variableByteSubclass: #Symbol
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!

ArrayedCollection variableByteSubclass: #ByteArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Arrayed'!

SequenceableCollection subclass: #Interval
	instanceVariableNames: 'start stop step'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Sequenceable'!

SequenceableCollection variableSubclass: #OrderedCollection
	instanceVariableNames: 'firstIndex lastIndex'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Sequenceable'!

OrderedCollection variableSubclass: #SortedCollection
	instanceVariableNames: 'sortBlock'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Sequenceable'!

Collection variableSubclass: #Set
	instanceVariableNames: 'tally'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Unordered'!

Set variableSubclass: #Dictionary
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Unordered'!

Collection subclass: #Bag
	instanceVariableNames: 'contents'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Unordered'!

Object subclass: #SystemDictionary
	instanceVariableNames: 'associations'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!

Object subclass: #Stream
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!

Stream subclass: #PositionableStream
	instanceVariableNames: 'collection position readLimit'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!

PositionableStream subclass: #ReadStream
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!

PositionableStream subclass: #WriteStream
	instanceVariableNames: 'writeLimit'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!

WriteStream subclass: #ReadWriteStream
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!

Object subclass: #MethodDictionary
	instanceVariableNames: 'selectors methods'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!

Object subclass: #CompiledMethod
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!

Object variableSubclass: #ContextPart
	instanceVariableNames: 'sender pc stackp'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!

ContextPart variableSubclass: #MethodContext
	instanceVariableNames: 'method unused receiver'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!

ContextPart variableSubclass: #BlockContext
	instanceVariableNames: 'nargs startpc home'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!

Object subclass: #TextCollector
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Transcript'!

Object subclass: #Time
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!

Object subclass: #Form
	instanceVariableNames: 'bits width height'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!

Object subclass: #BitBlt
	instanceVariableNames: 'destForm sourceForm halftoneForm combinationRule destX destY width height sourceX sourceY clipX clipY clipWidth clipHeight'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Support'!

BitBlt subclass: #Pen
	instanceVariableNames: 'frame location direction penDown'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Primitives'!

Object subclass: #InputSensor
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Processes'!
|st});
("Objects.st", {st|"Object, nil, the Booleans, and the two small classes everything
uses: Association (key -> value) and Message (what doesNotUnderstand:
receives)."!

!Object methodsFor: 'comparing'!
== anObject
	"The same object: the oops equal. Never fails."
	<primitive: 110>
	self primitiveFailed!

= anObject
	"Equal: by default, the same object. Subclasses say more."
	^self == anObject!

~= anObject
	^(self = anObject) == false!

~~ anObject
	^(self == anObject) == false!

hash
	"Equal objects must have equal hashes."
	^self identityHash!

identityHash
	<primitive: 75>
	self primitiveFailed! !

!Object methodsFor: 'class membership'!
class
	<primitive: 111>
	self primitiveFailed!

isKindOf: aClass
	| c |
	c := self class.
	[c == nil] whileFalse: [c == aClass ifTrue: [^true]. c := c superclass].
	^false!

isMemberOf: aClass
	^self class == aClass!

respondsTo: aSymbol
	^self class canUnderstand: aSymbol! !

!Object methodsFor: 'testing'!
isNil
	^false!

notNil
	^true!

isString
	^false!

isSymbol
	^false!

isNumber
	^false!

isInteger
	^false!

isSmallInteger
	^false!

isCharacter
	^false!

isClass
	^false!

isArray
	^false!

ifNil: aBlock
	^self!

ifNotNil: aBlock
	^aBlock value: self! !

!Object methodsFor: 'accessing'!
at: index
	"The indexed field, from 1."
	<primitive: 60>
	self checkIndex: index!

at: index put: value
	<primitive: 61>
	self checkIndex: index!

basicAt: index
	<primitive: 60>
	self checkIndex: index!

basicAt: index put: value
	<primitive: 61>
	self checkIndex: index!

size
	"How many indexed fields."
	<primitive: 62>
	^0!

basicSize
	<primitive: 62>
	^0!

instVarAt: index
	<primitive: 73>
	self error: 'Index out of bounds'!

instVarAt: index put: value
	<primitive: 74>
	self error: 'Index out of bounds'!

yourself
	^self!

checkIndex: index
	index isInteger ifFalse: [^self error: 'Index must be an integer'].
	(index < 1 or: [index > self basicSize])
		ifTrue: [^self error: 'Index out of bounds: ', index printString].
	^self error: 'Improper store into indexable object'! !

!Object methodsFor: 'copying'!
shallowCopy
	"A new object with the same fields: they are shared, not copied."
	<primitive: 153>
	self primitiveFailed!

copy
	^self shallowCopy!

deepCopy
	| new |
	new := self shallowCopy.
	1 to: self class instSize do: [:i | new instVarAt: i put: (self instVarAt: i) copy].
	^new! !

!Object methodsFor: 'printing'!
printString
	"What 'print it' shows: printOn: into a stream on a String."
	| aStream |
	aStream := WriteStream on: (String new: 16).
	self printOn: aStream.
	^aStream contents!

printOn: aStream
	"By default, the class's name with an article: a Point, an Object."
	| title |
	title := self class name.
	aStream nextPutAll: ((title at: 1) isVowel ifTrue: ['an '] ifFalse: ['a ']).
	aStream nextPutAll: title!

displayString
	^self printString!

displayNl
	Transcript show: self displayString; cr!

printNl
	Transcript show: self printString; cr! !

!Object methodsFor: 'error handling'!
error: aString
	"Stop the process, a notifier titled aString: St_debug.mli.
	Proceeding answers nil."
	<primitive: 141>!

doesNotUnderstand: aMessage
	"No method for aMessage selector, up the whole superclass chain."
	^self error: 'Message not understood: ', aMessage selector!

halt
	^self error: 'Halt'!

primitiveFailed
	^self error: 'Primitive failed'!

subclassResponsibility
	^self error: 'My subclass should have overridden one of my messages'!

shouldNotImplement
	^self error: 'This message is not appropriate for this object'!

mustBeBoolean
	^self error: 'NonBoolean receiver--proceed for truth'!

cannotReturn: value
	^self error: 'Context cannot return'! !

!Object methodsFor: 'message handling'!
perform: aSymbol
	<primitive: 83>
	^self error: 'Wrong number of arguments'!

perform: aSymbol with: anObject
	<primitive: 83>
	^self error: 'Wrong number of arguments'!

perform: aSymbol with: first with: second
	<primitive: 83>
	^self error: 'Wrong number of arguments'!

perform: aSymbol withArguments: anArray
	<primitive: 84>
	^self error: 'Wrong number of arguments'! !

!Object methodsFor: 'system primitives'!
become: otherObject
	"Swap the two objects: every reference to one now reaches the
	other (St_memory.mli)."
	<primitive: 72>
	self primitiveFailed!

inspect
	"An Inspector on the receiver."
	<primitive: 158>!

-> anObject
	^Association key: self value: anObject! !

!UndefinedObject methodsFor: 'testing'!
isNil
	^true!

notNil
	^false!

ifNil: aBlock
	^aBlock value!

ifNotNil: aBlock
	^self! !

!UndefinedObject methodsFor: 'printing'!
printOn: aStream
	aStream nextPutAll: 'nil'! !

!UndefinedObject methodsFor: 'class definition'!
subclass: nameSymbol instanceVariableNames: instVarNames classVariableNames: classVarNames poolDictionaries: pools category: categoryString
	"A class with no superclass: Object's own definition."
	<primitive: 143>
	self primitiveFailed! !

!Boolean methodsFor: 'printing'!
printOn: aStream
	aStream nextPutAll: (self ifTrue: ['true'] ifFalse: ['false'])! !

!Boolean methodsFor: 'copying'!
shallowCopy
	"true and false are unique."
	^self! !

!True methodsFor: 'controlling'!
ifTrue: trueBlock
	"Sent only when the argument is not a literal block: the compiler
	inlines the other cases into jumps (St_compile.mli)."
	^trueBlock value!

ifFalse: falseBlock
	^nil!

ifTrue: trueBlock ifFalse: falseBlock
	^trueBlock value!

ifFalse: falseBlock ifTrue: trueBlock
	^trueBlock value!

and: aBlock
	^aBlock value!

or: aBlock
	^true! !

!True methodsFor: 'logical operations'!
& aBoolean
	^aBoolean!

| aBoolean
	^true!

not
	^false! !

!False methodsFor: 'controlling'!
ifTrue: trueBlock
	^nil!

ifFalse: falseBlock
	^falseBlock value!

ifTrue: trueBlock ifFalse: falseBlock
	^falseBlock value!

ifFalse: falseBlock ifTrue: trueBlock
	^falseBlock value!

and: aBlock
	^false!

or: aBlock
	^aBlock value! !

!False methodsFor: 'logical operations'!
& aBoolean
	^false!

| aBoolean
	^aBoolean!

not
	^true! !

!Association class methodsFor: 'instance creation'!
key: aKey value: aValue
	^self new key: aKey value: aValue! !

!Association methodsFor: 'accessing'!
key
	^key!

value
	^value!

key: aKey value: aValue
	key := aKey.
	value := aValue!

value: aValue
	value := aValue! !

!Association methodsFor: 'comparing'!
= anAssociation
	^(anAssociation isKindOf: Association)
		and: [key = anAssociation key and: [value = anAssociation value]]!

hash
	^key hash! !

!Association methodsFor: 'printing'!
printOn: aStream
	key printOn: aStream.
	aStream nextPutAll: '->'.
	value printOn: aStream! !

!Message methodsFor: 'accessing'!
selector
	^selector!

arguments
	^arguments! !

!Message methodsFor: 'printing'!
printOn: aStream
	aStream nextPutAll: 'a Message ('; nextPutAll: selector.
	arguments do: [:each | aStream space; print: each].
	aStream nextPut: $)! !
|st});
("Classes.st", {st|"Classes are objects: Behavior (what makes instances and finds
methods), ClassDescription (instance variables' names, the methods'
categories), Class and Metaclass. And the objects of the machine
itself: the SystemDictionary Smalltalk, method dictionaries, compiled
methods, the contexts, and Time."!

!Behavior methodsFor: 'instance creation'!
new
	<primitive: 70>
	^self error: 'This class cannot make instances with new'!

new: anInteger
	<primitive: 71>
	^self error: 'This class cannot make indexed instances'!

basicNew
	<primitive: 70>
	self primitiveFailed!

basicNew: anInteger
	<primitive: 71>
	self primitiveFailed! !

!Behavior methodsFor: 'accessing'!
superclass
	^superclass!

methodDictionary
	^methodDict!

instSize
	"The named fields of an instance: the format's high bits."
	^format bitShift: -3!

isVariable
	^(format bitAnd: 7) between: 1 and: 2!

instanceVariableNames
	| names |
	names := superclass == nil ifTrue: [OrderedCollection new] ifFalse: [superclass instanceVariableNames].
	instanceVariables == nil ifFalse: [instanceVariables do: [:each | names add: each]].
	^names!

selectors
	<primitive: 149>
	self primitiveFailed!

allInstances
	<primitive: 145>
	self primitiveFailed!

subclasses
	| result |
	result := OrderedCollection new.
	Smalltalk classesDo: [:each | each superclass == self ifTrue: [result add: each]].
	^result!

withAllSuperclasses
	| result c |
	result := OrderedCollection new.
	c := self.
	[c == nil] whileFalse: [result add: c. c := c superclass].
	^result! !

!Behavior methodsFor: 'testing'!
isClass
	^true!

inheritsFrom: aClass
	| c |
	c := superclass.
	[c == nil] whileFalse: [c == aClass ifTrue: [^true]. c := c superclass].
	^false!

canUnderstand: aSymbol
	<primitive: 147>
	self primitiveFailed!

includesSelector: aSymbol
	<primitive: 148>
	self primitiveFailed! !

!Behavior methodsFor: 'compiling'!
compile: code classified: category
	"What the Browser's accept does: the selector, or the compiler's
	complaint, a String."
	<primitive: 142>
	self primitiveFailed!

compile: code
	^self compile: code classified: 'as yet unclassified'! !

!Behavior methodsFor: 'printing'!
printOn: aStream
	aStream nextPutAll: self name! !

!Class methodsFor: 'accessing'!
name
	^name!

category
	^category!

comment
	^comment!

comment: aString
	comment := aString! !

!Class methodsFor: 'subclass creation'!
subclass: nameSymbol instanceVariableNames: instVarNames classVariableNames: classVarNames poolDictionaries: pools category: categoryString
	<primitive: 143>
	self primitiveFailed!

variableSubclass: nameSymbol instanceVariableNames: instVarNames classVariableNames: classVarNames poolDictionaries: pools category: categoryString
	<primitive: 151>
	self primitiveFailed!

variableByteSubclass: nameSymbol instanceVariableNames: instVarNames classVariableNames: classVarNames poolDictionaries: pools category: categoryString
	<primitive: 152>
	self primitiveFailed! !

!Metaclass methodsFor: 'accessing'!
name
	^thisClass name , ' class'!

soleInstance
	^thisClass!

category
	^thisClass category! !

!SystemDictionary methodsFor: 'accessing'!
at: key
	^self at: key ifAbsent: [self error: 'Key not found: ', key]!

at: key ifAbsent: aBlock
	| a |
	a := self associationAt: key ifAbsent: [nil].
	a == nil ifTrue: [^aBlock value].
	^a value!

at: key put: value
	"The same Association kept: the methods that use the global see
	its new value (St_class.mli)."
	| a |
	a := self associationAt: key ifAbsent: [nil].
	a == nil ifFalse: [a value: value. ^value].
	associations := associations copyWith: (Association key: key asSymbol value: value).
	^value!

associationAt: key ifAbsent: aBlock
	| k |
	k := key asSymbol.
	associations do: [:each | each key == k ifTrue: [^each]].
	^aBlock value!

includesKey: key
	self associationAt: key ifAbsent: [^false].
	^true!

keys
	^associations collect: [:each | each key]!

classesDo: aBlock
	associations do: [:each | (each value isClass and: [each value name == each key]) ifTrue: [aBlock value: each value]]!

garbageCollect
	"The entries freed."
	<primitive: 146>
	self primitiveFailed! !

!SystemDictionary methodsFor: 'printing'!
printOn: aStream
	aStream nextPutAll: 'Smalltalk'! !

!MethodDictionary methodsFor: 'accessing'!
keys
	^selectors!

at: aSymbol
	1 to: selectors size do: [:i | (selectors at: i) == aSymbol ifTrue: [^methods at: i]].
	^self error: 'Key not found'!

size
	^selectors size! !

!CompiledMethod methodsFor: 'accessing'!
selector
	<primitive: 156>
	self primitiveFailed!

methodClass
	<primitive: 157>
	self primitiveFailed! !

!CompiledMethod methodsFor: 'printing'!
printOn: aStream
	aStream nextPutAll: self methodClass name; nextPutAll: '>>'; nextPutAll: self selector! !

!ContextPart methodsFor: 'controlling'!
blockCopy: numArgs
	"What the compiler sends for each [...]: a BlockContext that will
	start after the jump that follows this send (St_compile.mli)."
	<primitive: 80>
	self primitiveFailed! !

!ContextPart methodsFor: 'accessing'!
sender
	"The virtual machine answers it, to know that someone holds the
	sender now: a context nobody holds is used again (St_interp.mli)."
	<primitive: 159>
	^sender!

method
	^self subclassResponsibility!

receiver
	^self subclassResponsibility! !

!MethodContext methodsFor: 'accessing'!
method
	^method!

receiver
	^receiver!

home
	^self! !

!MethodContext methodsFor: 'printing'!
printOn: aStream
	"Point(Object)>>printString: the receiver's class, and the class
	the method was found in if another"
	| mclass |
	mclass := method methodClass.
	aStream nextPutAll: receiver class name.
	mclass == receiver class ifFalse: [aStream nextPut: $(; nextPutAll: mclass name; nextPut: $)].
	aStream nextPutAll: '>>'; nextPutAll: method selector! !

!BlockContext methodsFor: 'accessing'!
method
	^home method!

receiver
	^home receiver!

home
	^home!

numArgs
	^nargs! !

!BlockContext methodsFor: 'evaluating'!
value
	"Evaluate the block. It runs in this same context each time: the
	Blue Book's blocks are not reentrant (St_compile.mli)."
	<primitive: 81>
	^self error: 'Wrong number of arguments'!

value: arg
	<primitive: 81>
	^self error: 'Wrong number of arguments'!

value: arg1 value: arg2
	<primitive: 81>
	^self error: 'Wrong number of arguments'!

value: arg1 value: arg2 value: arg3
	<primitive: 81>
	^self error: 'Wrong number of arguments'!

value: arg1 value: arg2 value: arg3 value: arg4
	<primitive: 81>
	^self error: 'Wrong number of arguments'!

valueWithArguments: anArray
	<primitive: 82>
	^self error: 'Wrong number of arguments'! !

!BlockContext methodsFor: 'controlling'!
whileTrue: aBlock
	"Sent only when the compiler could not inline it."
	[self value] whileTrue: [aBlock value].
	^nil!

whileFalse: aBlock
	[self value] whileFalse: [aBlock value].
	^nil!

whileTrue
	[self value] whileTrue.
	^nil!

repeat
	[true] whileTrue: [self value]! !

!BlockContext methodsFor: 'printing'!
printOn: aStream
	aStream nextPutAll: '[] in '.
	home printOn: aStream! !

!Time class methodsFor: 'general inquiries'!
millisecondClock
	<primitive: 144>
	self primitiveFailed!

millisecondsToRun: aBlock
	| start |
	start := self millisecondClock.
	aBlock value.
	^self millisecondClock - start! !

!TextCollector methodsFor: 'accessing'!
show: aString
	"The Transcript's text, given to the host."
	<primitive: 140>
	^self show: aString printString!

nextPutAll: aString
	^self show: aString!

nextPut: aCharacter
	^self show: (String with: aCharacter)!

cr
	^self nextPut: Character cr!

tab
	^self nextPut: Character tab!

space
	^self nextPut: Character space!

print: anObject
	^self show: anObject printString!

display: anObject
	^self show: anObject displayString! !

!TextCollector methodsFor: 'printing'!
printOn: aStream
	aStream nextPutAll: 'a TextCollector'! !
|st});
("Numbers.st", {st|"The numbers. SmallInteger's arithmetic is primitives (and even the
bytecodes' own, St_interp.mli); when one fails -- an overflow, or an
argument of another kind -- the method's Smalltalk runs instead:
overflows go on in LargePositiveInteger and LargeNegativeInteger,
written here over their bytes as in the Blue Book, and mixed kinds are
coerced to the more general one (retry:coercing:, generality: a
SmallInteger 20, a large one 40, a Fraction 60, a Float 80)."!

!Magnitude methodsFor: 'comparing'!
< aMagnitude
	^self subclassResponsibility!

> aMagnitude
	^aMagnitude < self!

<= aMagnitude
	^(aMagnitude < self) not!

>= aMagnitude
	^(self < aMagnitude) not!

between: min and: max
	^self >= min and: [self <= max]!

max: aMagnitude
	^self > aMagnitude ifTrue: [self] ifFalse: [aMagnitude]!

min: aMagnitude
	^self < aMagnitude ifTrue: [self] ifFalse: [aMagnitude]! !

!Character class methodsFor: 'instance creation'!
value: anInteger
	"The unique Character of a code: $a == (Character value: 97)."
	<primitive: 120>
	^self error: 'Not a character code'!

digitValue: anInteger
	^'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ' at: anInteger + 1!

cr
	^self value: 13!

lf
	^self value: 10!

tab
	^self value: 9!

space
	^self value: 32! !

!Character methodsFor: 'accessing'!
value
	^value!

asInteger
	^value!

asCharacter
	^self!

digitValue
	value <= 57 ifTrue: [^value - 48].
	value <= 90 ifTrue: [^value - 55].
	^value - 87! !

!Character methodsFor: 'comparing'!
< aCharacter
	^value < aCharacter asInteger!

= aCharacter
	^self == aCharacter!

hash
	^value! !

!Character methodsFor: 'testing'!
isCharacter
	^true!

isVowel
	^'aeiouAEIOU' includes: self!

isLetter
	^self isUppercase or: [self isLowercase]!

isUppercase
	^value between: 65 and: 90!

isLowercase
	^value between: 97 and: 122!

isDigit
	^value between: 48 and: 57!

isSeparator
	^value = 32 or: [value = 13 or: [value = 9 or: [value = 10]]]! !

!Character methodsFor: 'converting'!
asUppercase
	self isLowercase ifTrue: [^Character value: value - 32].
	^self!

asLowercase
	self isUppercase ifTrue: [^Character value: value + 32].
	^self!

asString
	^String with: self! !

!Character methodsFor: 'printing'!
printOn: aStream
	aStream nextPut: $$; nextPut: self!

displayString
	^String with: self! !

!Character methodsFor: 'copying'!
shallowCopy
	^self! !

!Number methodsFor: 'arithmetic'!
+ aNumber
	^self subclassResponsibility!

- aNumber
	^self + aNumber negated!

negated
	^0 - self!

abs
	self negative ifTrue: [^self negated].
	^self!

reciprocal
	^1 / self!

squared
	^self * self!

// aNumber
	^(self / aNumber) floor!

\\ aNumber
	^self - (self // aNumber * aNumber)!

quo: aNumber
	^(self / aNumber) truncated!

rem: aNumber
	^self - ((self quo: aNumber) * aNumber)!

raisedTo: anInteger
	| result |
	anInteger < 0 ifTrue: [^(self raisedTo: anInteger negated) reciprocal].
	result := 1.
	anInteger timesRepeat: [result := result * self].
	^result!

sqrt
	^self asFloat sqrt! !

!Number methodsFor: 'testing'!
isNumber
	^true!

negative
	^self < 0!

positive
	^self >= 0!

strictlyPositive
	^self > 0!

isZero
	^self = 0!

sign
	self > 0 ifTrue: [^1].
	self < 0 ifTrue: [^-1].
	^0!

even
	^self \\ 2 = 0!

odd
	^self even not! !

!Number methodsFor: 'truncation and round off'!
truncated
	^self subclassResponsibility!

floor
	| t |
	t := self truncated.
	(self < 0 and: [t ~= self]) ifTrue: [^t - 1].
	^t!

ceiling
	| t |
	t := self truncated.
	(self > 0 and: [t ~= self]) ifTrue: [^t + 1].
	^t!

rounded
	^(self + (self sign / 2)) truncated!

asInteger
	^self truncated! !

!Number methodsFor: 'coercing'!
generality
	^self subclassResponsibility!

coerce: aNumber
	^self subclassResponsibility!

retry: aSymbol coercing: aNumber
	"Do the operation again, the less general number made like the
	other: 3 + (1/2) becomes (3/1) + (1/2)."
	aNumber isNumber ifFalse: [
		aSymbol == #= ifTrue: [^false].
		aSymbol == #~= ifTrue: [^true].
		^self error: 'Not a number: ', aNumber printString].
	self generality < aNumber generality
		ifTrue: [^(aNumber coerce: self) perform: aSymbol with: aNumber].
	self generality > aNumber generality
		ifTrue: [^self perform: aSymbol with: (self coerce: aNumber)].
	^self error: 'Coercion failed'! !

!Number methodsFor: 'intervals'!
to: stop
	^Interval from: self to: stop by: 1!

to: stop by: step
	^Interval from: self to: stop by: step!

to: stop do: aBlock
	"Sent only when the compiler could not inline it."
	| i |
	i := self.
	[i <= stop] whileTrue: [aBlock value: i. i := i + 1]!

to: stop by: step do: aBlock
	| i |
	i := self.
	step > 0
		ifTrue: [[i <= stop] whileTrue: [aBlock value: i. i := i + step]]
		ifFalse: [[i >= stop] whileTrue: [aBlock value: i. i := i + step]]! !

!Number methodsFor: 'converting'!
@ y
	"A Point."
	<primitive: 18>
	^Point x: self y: y!

asPoint
	^self @ self! !

!Number methodsFor: 'printing'!
printString: base
	| aStream |
	aStream := WriteStream on: (String new: 16).
	self printOn: aStream base: base.
	^aStream contents! !

!Integer methodsFor: 'testing'!
isInteger
	^true! !

!Integer methodsFor: 'arithmetic'!
+ anInteger
	"Here when a large integer is involved: SmallInteger's own + is a
	primitive."
	anInteger isInteger ifFalse: [^self retry: #+ coercing: anInteger].
	^self asLargeInteger digitPlus: anInteger asLargeInteger!

- anInteger
	anInteger isInteger ifFalse: [^self retry: #- coercing: anInteger].
	^self asLargeInteger digitPlus: anInteger negated asLargeInteger!

* anInteger
	anInteger isInteger ifFalse: [^self retry: #* coercing: anInteger].
	^self asLargeInteger digitTimes: anInteger asLargeInteger!

/ anInteger
	"An Integer if it divides exactly, else a Fraction."
	anInteger isInteger ifFalse: [^self retry: #/ coercing: anInteger].
	anInteger = 0 ifTrue: [^self error: 'Division by zero'].
	^(Fraction numerator: self denominator: anInteger) reduced!

quo: anInteger
	"Truncated towards zero."
	anInteger isInteger ifFalse: [^self retry: #quo: coercing: anInteger].
	anInteger = 0 ifTrue: [^self error: 'Division by zero'].
	^(self digitDivide: anInteger) at: 1!

rem: anInteger
	anInteger isInteger ifFalse: [^self retry: #rem: coercing: anInteger].
	anInteger = 0 ifTrue: [^self error: 'Division by zero'].
	^(self digitDivide: anInteger) at: 2!

// anInteger
	"Truncated towards minus infinity."
	| qr |
	anInteger isInteger ifFalse: [^self retry: #// coercing: anInteger].
	anInteger = 0 ifTrue: [^self error: 'Division by zero'].
	qr := self digitDivide: anInteger.
	((qr at: 2) ~= 0 and: [self negative ~~ anInteger negative]) ifTrue: [^(qr at: 1) - 1].
	^qr at: 1!

\\ anInteger
	"The remainder of //: the sign of the divisor."
	| r |
	anInteger isInteger ifFalse: [^self retry: #\\ coercing: anInteger].
	anInteger = 0 ifTrue: [^self error: 'Division by zero'].
	r := (self digitDivide: anInteger) at: 2.
	(r ~= 0 and: [r negative ~~ anInteger negative]) ifTrue: [^r + anInteger].
	^r!

< anInteger
	anInteger isInteger ifFalse: [^self retry: #< coercing: anInteger].
	^(self asLargeInteger compareWith: anInteger asLargeInteger) < 0!

= anInteger
	anInteger isNumber ifFalse: [^false].
	anInteger isInteger ifFalse: [^self retry: #= coercing: anInteger].
	^(self asLargeInteger compareWith: anInteger asLargeInteger) = 0!

hash
	^(self \\ 1073741823) hash!

negated
	^0 - self!

gcd: anInteger
	"Euclid's."
	| a b t |
	a := self abs.
	b := anInteger abs.
	[b = 0] whileFalse: [t := a \\ b. a := b. b := t].
	^a!

lcm: anInteger
	^(self * anInteger) abs // (self gcd: anInteger)!

factorial
	"100 factorial printString size = 158."
	| result |
	self < 0 ifTrue: [^self error: 'Not valid for negative integers'].
	result := 1.
	2 to: self do: [:i | result := result * i].
	^result!

timesRepeat: aBlock
	| i |
	i := 1.
	[i <= self] whileTrue: [aBlock value. i := i + 1]!

isPrime
	self < 2 ifTrue: [^false].
	2 to: self sqrtFloor do: [:i | self \\ i = 0 ifTrue: [^false]].
	^true!

sqrtFloor
	| r |
	r := self asFloat sqrt truncated.
	[r * r > self] whileTrue: [r := r - 1].
	[(r + 1) * (r + 1) <= self] whileTrue: [r := r + 1].
	^r! !

!Integer methodsFor: 'coercing'!
generality
	^40!

coerce: aNumber
	^aNumber asLargeInteger! !

!Integer methodsFor: 'converting'!
asFloat
	"A large integer's bytes, summed as floats."
	| f |
	f := 0.0.
	self digitLength to: 1 by: -1 do: [:i | f := f * 256.0 + (self digitAt: i)].
	self negative ifTrue: [^f negated].
	^f!

truncated
	^self!

asCharacter
	^Character value: self!

digitDivide: anInteger
	"The quotient and the remainder truncated towards zero, an Array:
	by the schoolbook's short division when the divisor is small
	enough for a digit times it to stay a SmallInteger, else bit by
	bit."
	| a b qr q r |
	a := self abs asLargeInteger.
	b := anInteger abs.
	qr := (b isSmallInteger and: [b < 4194304])
		ifTrue: [a shortDivide: b]
		ifFalse: [a longDivide: b].
	q := qr at: 1.
	r := qr at: 2.
	self negative == anInteger negative ifFalse: [q := q negated].
	self negative ifTrue: [r := r negated].
	^Array with: q with: r! !

!Integer methodsFor: 'printing'!
printOn: aStream
	self printOn: aStream base: 10!

printOn: aStream base: base
	self < 0 ifTrue: [aStream nextPut: $-. ^self negated printOn: aStream base: base].
	self >= base ifTrue: [self // base printOn: aStream base: base].
	aStream nextPut: (Character digitValue: self \\ base)! !

!SmallInteger class methodsFor: 'instance creation'!
new
	^self error: 'SmallIntegers are not made, they are'! !

!SmallInteger methodsFor: 'arithmetic'!
+ aNumber
	<primitive: 1>
	^super + aNumber!

- aNumber
	<primitive: 2>
	^super - aNumber!

< aNumber
	<primitive: 3>
	^super < aNumber!

> aNumber
	<primitive: 4>
	^super > aNumber!

<= aNumber
	<primitive: 5>
	^super <= aNumber!

>= aNumber
	<primitive: 6>
	^super >= aNumber!

= aNumber
	<primitive: 7>
	^super = aNumber!

~= aNumber
	<primitive: 8>
	^super ~= aNumber!

* aNumber
	<primitive: 9>
	^super * aNumber!

/ aNumber
	<primitive: 10>
	^super / aNumber!

\\ aNumber
	<primitive: 11>
	^super \\ aNumber!

// aNumber
	<primitive: 12>
	^super // aNumber!

quo: aNumber
	<primitive: 13>
	^super quo: aNumber!

bitAnd: anInteger
	<primitive: 14>
	^self error: 'Not a SmallInteger'!

bitOr: anInteger
	<primitive: 15>
	^self error: 'Not a SmallInteger'!

bitXor: anInteger
	<primitive: 16>
	^self error: 'Not a SmallInteger'!

bitShift: anInteger
	<primitive: 17>
	anInteger > 0 ifTrue: [^self asLargeInteger * (2 raisedTo: anInteger)].
	^self error: 'Not a SmallInteger'! !

!SmallInteger methodsFor: 'testing'!
isSmallInteger
	^true!

even
	^(self bitAnd: 1) = 0! !

!SmallInteger methodsFor: 'coercing'!
generality
	^20!

coerce: aNumber
	^aNumber!

asLargeInteger
	<primitive: 154>
	self primitiveFailed! !

!SmallInteger methodsFor: 'converting'!
asFloat
	<primitive: 40>
	self primitiveFailed!

hash
	^self! !

!SmallInteger methodsFor: 'copying'!
shallowCopy
	^self! !

!LargePositiveInteger methodsFor: 'digits'!
digitAt: index
	"A byte of the magnitude, least significant first; 0 past the end."
	<primitive: 60>
	^0!

digitAt: index put: value
	<primitive: 61>
	self primitiveFailed!

digitLength
	<primitive: 62>
	self primitiveFailed!

normalize
	"The leading zero bytes dropped, a SmallInteger if it fits."
	<primitive: 155>
	self primitiveFailed!

asLargeInteger
	^self!

negative
	^false!

negated
	| result |
	result := (self negative ifTrue: [LargePositiveInteger] ifFalse: [LargeNegativeInteger]) new: self digitLength.
	1 to: self digitLength do: [:i | result digitAt: i put: (self digitAt: i)].
	^result normalize!

abs
	self negative ifTrue: [^self negated].
	^self! !

!LargePositiveInteger methodsFor: 'digit arithmetic'!
digitPlus: arg
	"The sum of two large integers of any signs."
	self negative == arg negative
		ifTrue: [^(self magnitudeAdd: arg negative: self negative) normalize].
	(self magnitudeCompare: arg) >= 0
		ifTrue: [^(self magnitudeSubtract: arg negative: self negative) normalize].
	^(arg magnitudeSubtract: self negative: arg negative) normalize!

magnitudeAdd: arg negative: aBoolean
	| len result carry sum |
	len := (self digitLength max: arg digitLength) + 1.
	result := (aBoolean ifTrue: [LargeNegativeInteger] ifFalse: [LargePositiveInteger]) new: len.
	carry := 0.
	1 to: len do: [:i |
		sum := (self digitAt: i) + (arg digitAt: i) + carry.
		result digitAt: i put: (sum bitAnd: 255).
		carry := sum bitShift: -8].
	^result!

magnitudeSubtract: arg negative: aBoolean
	"The receiver's magnitude is the larger."
	| len result borrow diff |
	len := self digitLength.
	result := (aBoolean ifTrue: [LargeNegativeInteger] ifFalse: [LargePositiveInteger]) new: len.
	borrow := 0.
	1 to: len do: [:i |
		diff := (self digitAt: i) - (arg digitAt: i) - borrow.
		diff < 0
			ifTrue: [diff := diff + 256. borrow := 1]
			ifFalse: [borrow := 0].
		result digitAt: i put: diff].
	^result!

magnitudeCompare: arg
	"-1, 0 or 1."
	| a b |
	(self digitLength max: arg digitLength) to: 1 by: -1 do: [:i |
		a := self digitAt: i.
		b := arg digitAt: i.
		a < b ifTrue: [^-1].
		a > b ifTrue: [^1]].
	^0!

compareWith: arg
	self negative == arg negative ifFalse: [self negative ifTrue: [^-1] ifFalse: [^1]].
	self negative ifTrue: [^arg magnitudeCompare: self].
	^self magnitudeCompare: arg!

digitTimes: arg
	"The schoolbook's: each digit of one by each of the other."
	| la lb result carry prod k |
	la := self digitLength.
	lb := arg digitLength.
	result := (self negative == arg negative ifTrue: [LargePositiveInteger] ifFalse: [LargeNegativeInteger]) new: la + lb.
	1 to: la do: [:i |
		carry := 0.
		1 to: lb do: [:j |
			k := i + j - 1.
			prod := (self digitAt: i) * (arg digitAt: j) + (result digitAt: k) + carry.
			result digitAt: k put: (prod bitAnd: 255).
			carry := prod bitShift: -8].
		result digitAt: i + lb put: carry].
	^result normalize!

shortDivide: divisor
	"The magnitude by a small SmallInteger, a digit at a time from the
	top: the quotient and the remainder."
	| len q r |
	len := self digitLength.
	q := LargePositiveInteger new: len.
	r := 0.
	len to: 1 by: -1 do: [:i |
		r := r * 256 + (self digitAt: i).
		q digitAt: i put: r // divisor.
		r := r \\ divisor].
	^Array with: q normalize with: r!

longDivide: divisor
	"A bit at a time: slow, but only for large divisors."
	| q r bit |
	q := 0.
	r := 0.
	self digitLength * 8 to: 1 by: -1 do: [:i |
		bit := ((self digitAt: i - 1 // 8 + 1) bitShift: 0 - (i - 1 \\ 8)) bitAnd: 1.
		r := r * 2 + bit.
		q := q * 2.
		r >= divisor ifTrue: [r := r - divisor. q := q + 1]].
	^Array with: q with: r! !

!LargePositiveInteger methodsFor: 'bit manipulation'!
bitShift: anInteger
	anInteger >= 0 ifTrue: [^self * (2 raisedTo: anInteger)].
	^self // (2 raisedTo: anInteger negated)!

hash
	^self digitAt: 1! !

!LargeNegativeInteger methodsFor: 'testing'!
negative
	^true! !

!Fraction class methodsFor: 'instance creation'!
numerator: n denominator: d
	"Not reduced: Integer>>/ reduces it."
	^self new setNumerator: n denominator: d! !

!Fraction methodsFor: 'private'!
setNumerator: n denominator: d
	d < 0
		ifTrue: [numerator := n negated. denominator := d negated]
		ifFalse: [numerator := n. denominator := d]! !

!Fraction methodsFor: 'accessing'!
numerator
	^numerator!

denominator
	^denominator! !

!Fraction methodsFor: 'arithmetic'!
+ aNumber
	aNumber isNumber ifFalse: [^self retry: #+ coercing: aNumber].
	aNumber generality = self generality ifFalse: [^self retry: #+ coercing: aNumber].
	^(Fraction
		numerator: numerator * aNumber denominator + (aNumber numerator * denominator)
		denominator: denominator * aNumber denominator) reduced!

- aNumber
	aNumber isNumber ifFalse: [^self retry: #- coercing: aNumber].
	aNumber generality = self generality ifFalse: [^self retry: #- coercing: aNumber].
	^(Fraction
		numerator: numerator * aNumber denominator - (aNumber numerator * denominator)
		denominator: denominator * aNumber denominator) reduced!

* aNumber
	aNumber isNumber ifFalse: [^self retry: #* coercing: aNumber].
	aNumber generality = self generality ifFalse: [^self retry: #* coercing: aNumber].
	^(Fraction
		numerator: numerator * aNumber numerator
		denominator: denominator * aNumber denominator) reduced!

/ aNumber
	aNumber isNumber ifFalse: [^self retry: #/ coercing: aNumber].
	aNumber generality = self generality ifFalse: [^self retry: #/ coercing: aNumber].
	^(Fraction
		numerator: numerator * aNumber denominator
		denominator: denominator * aNumber numerator) reduced!

negated
	^Fraction numerator: numerator negated denominator: denominator!

reduced
	"Lowest terms, and an Integer when the denominator is 1."
	| g |
	numerator = 0 ifTrue: [^0].
	g := numerator gcd: denominator.
	g = denominator ifTrue: [^numerator // g].
	^Fraction numerator: numerator // g denominator: denominator // g! !

!Fraction methodsFor: 'comparing'!
< aNumber
	aNumber isNumber ifFalse: [^self retry: #< coercing: aNumber].
	aNumber generality = self generality ifFalse: [^self retry: #< coercing: aNumber].
	^numerator * aNumber denominator < (aNumber numerator * denominator)!

= aNumber
	aNumber isNumber ifFalse: [^false].
	aNumber generality = self generality ifFalse: [^self retry: #= coercing: aNumber].
	^numerator = aNumber numerator and: [denominator = aNumber denominator]!

hash
	^numerator hash bitXor: denominator hash! !

!Fraction methodsFor: 'truncation and round off'!
truncated
	^numerator quo: denominator! !

!Fraction methodsFor: 'coercing'!
generality
	^60!

coerce: aNumber
	^Fraction numerator: aNumber denominator: 1! !

!Fraction methodsFor: 'converting'!
asFloat
	^numerator asFloat / denominator asFloat! !

!Fraction methodsFor: 'printing'!
printOn: aStream
	aStream print: numerator; nextPut: $/; print: denominator! !

!Float methodsFor: 'arithmetic'!
+ aNumber
	<primitive: 41>
	^self retry: #+ coercing: aNumber!

- aNumber
	<primitive: 42>
	^self retry: #- coercing: aNumber!

< aNumber
	<primitive: 43>
	^self retry: #< coercing: aNumber!

> aNumber
	<primitive: 44>
	^self retry: #> coercing: aNumber!

<= aNumber
	<primitive: 45>
	^self retry: #<= coercing: aNumber!

>= aNumber
	<primitive: 46>
	^self retry: #>= coercing: aNumber!

= aNumber
	<primitive: 47>
	^self retry: #= coercing: aNumber!

~= aNumber
	<primitive: 48>
	^self retry: #~= coercing: aNumber!

* aNumber
	<primitive: 49>
	^self retry: #* coercing: aNumber!

/ aNumber
	<primitive: 50>
	aNumber = 0 ifTrue: [^self error: 'Division by zero'].
	^self retry: #/ coercing: aNumber!

sqrt
	<primitive: 55>
	self primitiveFailed!

sin
	<primitive: 56>
	self primitiveFailed!

cos
	^(self + 1.5707963267948966) sin!

arcTan
	<primitive: 57>
	self primitiveFailed!

ln
	<primitive: 58>
	self primitiveFailed!

exp
	<primitive: 59>
	self primitiveFailed! !

!Float methodsFor: 'truncation and round off'!
truncated
	"Too large for a SmallInteger: the high part and the low part."
	| q |
	<primitive: 51>
	q := (self / 65536.0) truncated.
	^q * 65536 + (self - (q * 65536.0)) truncated! !

!Float methodsFor: 'truncation and round off'!
rounded
	^(self + (self sign * 0.5)) truncated! !

!Float methodsFor: 'coercing'!
generality
	^80!

coerce: aNumber
	^aNumber asFloat!

asFloat
	^self!

hash
	^self truncated hash! !

!Float methodsFor: 'printing'!
printString
	<primitive: 130>
	self primitiveFailed!

printOn: aStream
	aStream nextPutAll: self printString! !

!Point class methodsFor: 'instance creation'!
x: xInteger y: yInteger
	^self new setX: xInteger setY: yInteger! !

!Point methodsFor: 'private'!
setX: xValue setY: yValue
	x := xValue.
	y := yValue! !

!Point methodsFor: 'accessing'!
x
	^x!

y
	^y! !

!Point methodsFor: 'arithmetic'!
+ arg
	| p |
	p := arg asPoint.
	^(x + p x) @ (y + p y)!

- arg
	| p |
	p := arg asPoint.
	^(x - p x) @ (y - p y)!

* arg
	| p |
	p := arg asPoint.
	^(x * p x) @ (y * p y)!

/ arg
	| p |
	p := arg asPoint.
	^(x / p x) @ (y / p y)!

// arg
	| p |
	p := arg asPoint.
	^(x // p x) @ (y // p y)!

abs
	^x abs @ y abs! !

!Point methodsFor: 'comparing'!
= aPoint
	^(aPoint isKindOf: Point) and: [x = aPoint x and: [y = aPoint y]]!

hash
	^x hash bitXor: y hash!

< aPoint
	^x < aPoint x and: [y < aPoint y]!

> aPoint
	^x > aPoint x and: [y > aPoint y]!

<= aPoint
	^x <= aPoint x and: [y <= aPoint y]!

>= aPoint
	^x >= aPoint x and: [y >= aPoint y]!

max: aPoint
	^(x max: aPoint x) @ (y max: aPoint y)!

min: aPoint
	^(x min: aPoint x) @ (y min: aPoint y)! !

!Point methodsFor: 'point functions'!
dist: aPoint
	| dx dy |
	dx := aPoint x - x.
	dy := aPoint y - y.
	^(dx * dx + (dy * dy)) sqrt!

transpose
	^y @ x!

corner: aPoint
	^Rectangle origin: self corner: aPoint!

extent: aPoint
	^Rectangle origin: self corner: self + aPoint! !

!Point methodsFor: 'converting'!
asPoint
	^self! !

!Point methodsFor: 'printing'!
printOn: aStream
	x printOn: aStream.
	aStream nextPut: $@.
	y printOn: aStream! !

!Rectangle class methodsFor: 'instance creation'!
origin: originPoint corner: cornerPoint
	^self new setOrigin: originPoint corner: cornerPoint! !

!Rectangle methodsFor: 'private'!
setOrigin: originPoint corner: cornerPoint
	origin := originPoint.
	corner := cornerPoint! !

!Rectangle methodsFor: 'accessing'!
origin
	^origin!

corner
	^corner!

width
	^corner x - origin x!

height
	^corner y - origin y!

extent
	^corner - origin!

area
	^self width * self height! !

!Rectangle methodsFor: 'rectangle functions'!
center
	"The Blue Book's example of compiled code (St_bytecode.mli):
	0 1 176 119 185 124."
	^origin + corner / 2!

containsPoint: aPoint
	^origin <= aPoint and: [aPoint < corner]!

intersects: aRectangle
	^(origin max: aRectangle origin) < (corner min: aRectangle corner)! !

!Rectangle methodsFor: 'comparing'!
= aRectangle
	^(aRectangle isKindOf: Rectangle) and: [origin = aRectangle origin and: [corner = aRectangle corner]]!

hash
	^origin hash bitXor: corner hash! !

!Rectangle methodsFor: 'printing'!
printOn: aStream
	origin printOn: aStream.
	aStream nextPutAll: ' corner: '.
	corner printOn: aStream! !
|st});
("Collections.st", {st|"The collections, and their iteration protocol -- do:, collect:,
select:, reject:, detect:, inject:into: -- the one the rest of the
world copied (Ruby's each, map, select, detect, inject; Python's
comprehensions). Every collection answers them once it has do:.

OrderedCollection and Set grow the Blue Book's way: a bigger copy,
then 'self become: newSelf' (St_memory.mli), so that everything that
knew the collection now knows the bigger one."!

!Collection class methodsFor: 'instance creation'!
with: anObject
	^self new add: anObject; yourself!

with: first with: second
	^self new add: first; add: second; yourself!

with: first with: second with: third
	^self new add: first; add: second; add: third; yourself!

with: first with: second with: third with: fourth
	^self new add: first; add: second; add: third; add: fourth; yourself!

withAll: aCollection
	^self new addAll: aCollection; yourself! !

!Collection methodsFor: 'adding'!
add: anObject
	^self subclassResponsibility!

addAll: aCollection
	aCollection do: [:each | self add: each].
	^aCollection! !

!Collection methodsFor: 'removing'!
remove: oldObject
	^self remove: oldObject ifAbsent: [self error: 'Object is not in the collection']!

remove: oldObject ifAbsent: aBlock
	^self subclassResponsibility!

removeAll: aCollection
	aCollection do: [:each | self remove: each].
	^aCollection! !

!Collection methodsFor: 'testing'!
includes: anObject
	self do: [:each | anObject = each ifTrue: [^true]].
	^false!

isEmpty
	^self size = 0!

notEmpty
	^self isEmpty not!

occurrencesOf: anObject
	| tally |
	tally := 0.
	self do: [:each | anObject = each ifTrue: [tally := tally + 1]].
	^tally! !

!Collection methodsFor: 'accessing'!
size
	| tally |
	tally := 0.
	self do: [:each | tally := tally + 1].
	^tally! !

!Collection methodsFor: 'enumerating'!
do: aBlock
	^self subclassResponsibility!

do: aBlock separatedBy: separatorBlock
	| first |
	first := true.
	self do: [:each |
		first ifTrue: [first := false] ifFalse: [separatorBlock value].
		aBlock value: each]!

collect: aBlock
	| result |
	result := OrderedCollection new.
	self do: [:each | result add: (aBlock value: each)].
	^result!

select: aBlock
	| result |
	result := self species new.
	self do: [:each | (aBlock value: each) ifTrue: [result add: each]].
	^result!

reject: aBlock
	^self select: [:each | (aBlock value: each) == false]!

detect: aBlock
	^self detect: aBlock ifNone: [self error: 'Object is not in the collection']!

detect: aBlock ifNone: exceptionBlock
	self do: [:each | (aBlock value: each) ifTrue: [^each]].
	^exceptionBlock value!

inject: thisValue into: binaryBlock
	| nextValue |
	nextValue := thisValue.
	self do: [:each | nextValue := binaryBlock value: nextValue value: each].
	^nextValue!

anySatisfy: aBlock
	self do: [:each | (aBlock value: each) ifTrue: [^true]].
	^false!

allSatisfy: aBlock
	self do: [:each | (aBlock value: each) ifFalse: [^false]].
	^true!

max
	^self inject: self anyOne into: [:a :b | a max: b]!

min
	^self inject: self anyOne into: [:a :b | a min: b]!

sum
	^self inject: 0 into: [:a :b | a + b]!

anyOne
	self do: [:each | ^each].
	^self error: 'Collection is empty'! !

!Collection methodsFor: 'converting'!
asArray
	| result i |
	result := Array new: self size.
	i := 0.
	self do: [:each | result at: (i := i + 1) put: each].
	^result!

asOrderedCollection
	^OrderedCollection withAll: self!

asBag
	^Bag withAll: self!

asSet
	^Set withAll: self!

asSortedCollection
	^SortedCollection withAll: self!

asSortedCollection: aBlock
	^(SortedCollection sortBlock: aBlock) addAll: self; yourself! !

!Collection methodsFor: 'private'!
species
	^self class! !

!Collection methodsFor: 'printing'!
printOn: aStream
	"OrderedCollection (1 2 3 ), as the Blue Book prints it."
	aStream nextPutAll: self class name; nextPutAll: ' ('.
	self do: [:element | element printOn: aStream. aStream space].
	aStream nextPut: $)! !

!SequenceableCollection methodsFor: 'comparing'!
= aCollection
	self class == aCollection class ifFalse: [^false].
	self size = aCollection size ifFalse: [^false].
	1 to: self size do: [:i | (self at: i) = (aCollection at: i) ifFalse: [^false]].
	^true!

hash
	^self size! !

!SequenceableCollection methodsFor: 'accessing'!
first
	self isEmpty ifTrue: [^self error: 'Collection is empty'].
	^self at: 1!

last
	self isEmpty ifTrue: [^self error: 'Collection is empty'].
	^self at: self size!

indexOf: anElement
	1 to: self size do: [:i | (self at: i) = anElement ifTrue: [^i]].
	^0!

allButFirst
	^self copyFrom: 2 to: self size!

allButLast
	^self copyFrom: 1 to: self size - 1! !

!SequenceableCollection methodsFor: 'enumerating'!
do: aBlock
	1 to: self size do: [:i | aBlock value: (self at: i)]!

reverseDo: aBlock
	self size to: 1 by: -1 do: [:i | aBlock value: (self at: i)]!

doWithIndex: aBlock
	1 to: self size do: [:i | aBlock value: (self at: i) value: i]!

keysAndValuesDo: aBlock
	1 to: self size do: [:i | aBlock value: i value: (self at: i)]!

with: aCollection do: aBlock
	1 to: self size do: [:i | aBlock value: (self at: i) value: (aCollection at: i)]!

collect: aBlock
	| result |
	result := self species new: self size.
	1 to: self size do: [:i | result at: i put: (aBlock value: (self at: i))].
	^result!

select: aBlock
	| result |
	result := OrderedCollection new.
	self do: [:each | (aBlock value: each) ifTrue: [result add: each]].
	^(self species inheritsFrom: ArrayedCollection)
		ifTrue: [(self species new: result size) replaceFrom: 1 to: result size with: result startingAt: 1]
		ifFalse: [result]! !

!SequenceableCollection methodsFor: 'copying'!
copyFrom: start to: stop
	| result |
	result := self species new: (stop - start + 1 max: 0).
	start to: stop do: [:i | result at: i - start + 1 put: (self at: i)].
	^result!

copyWith: newElement
	| result |
	result := self species new: self size + 1.
	result replaceFrom: 1 to: self size with: self startingAt: 1.
	result at: result size put: newElement.
	^result!

reversed
	| result n |
	n := self size.
	result := self species new: n.
	1 to: n do: [:i | result at: i put: (self at: n + 1 - i)].
	^result!

reverse
	^self reversed!

replaceFrom: start to: stop with: replacement startingAt: repStart
	| j |
	j := repStart.
	start to: stop do: [:i | self at: i put: (replacement at: j). j := j + 1]!

, aSequenceableCollection
	| result |
	result := self species new: self size + aSequenceableCollection size.
	result replaceFrom: 1 to: self size with: self startingAt: 1.
	result replaceFrom: self size + 1 to: result size with: aSequenceableCollection startingAt: 1.
	^result! !

!SequenceableCollection methodsFor: 'converting'!
readStream
	^ReadStream on: self! !

!ArrayedCollection class methodsFor: 'instance creation'!
new
	^self new: 0!

with: anObject
	^(self new: 1) at: 1 put: anObject; yourself!

with: first with: second
	^(self new: 2) at: 1 put: first; at: 2 put: second; yourself!

with: first with: second with: third
	^(self new: 3) at: 1 put: first; at: 2 put: second; at: 3 put: third; yourself!

with: first with: second with: third with: fourth
	^(self new: 4) at: 1 put: first; at: 2 put: second; at: 3 put: third; at: 4 put: fourth; yourself!

withAll: aCollection
	| result i |
	result := self new: aCollection size.
	i := 0.
	aCollection do: [:each | result at: (i := i + 1) put: each].
	^result! !

!ArrayedCollection methodsFor: 'accessing'!
size
	<primitive: 62>
	^0! !

!ArrayedCollection methodsFor: 'adding'!
add: anObject
	^self shouldNotImplement! !

!ArrayedCollection methodsFor: 'copying'!
replaceFrom: start to: stop with: replacement startingAt: repStart
	"The primitive when both are pointers or both bytes."
	<primitive: 105>
	^super replaceFrom: start to: stop with: replacement startingAt: repStart! !

!ArrayedCollection methodsFor: 'sorting'!
asSortedArray
	^self asSortedCollection asArray! !

!Array methodsFor: 'testing'!
isArray
	^true! !

!Array methodsFor: 'printing'!
printOn: aStream
	"#(1 $a 'b'), as a literal reads"
	aStream nextPutAll: '#('.
	self do: [:each | each printOn: aStream] separatedBy: [aStream space].
	aStream nextPut: $)! !

!String class methodsFor: 'instance creation'!
new
	^self new: 0! !

!String methodsFor: 'accessing'!
at: index
	"A Character: the bytes are characters."
	<primitive: 63>
	^self checkIndex: index!

at: index put: aCharacter
	<primitive: 64>
	aCharacter isCharacter ifFalse: [^self error: 'Strings only store Characters'].
	^self checkIndex: index!

size
	<primitive: 62>
	^0! !

!String methodsFor: 'comparing'!
= aString
	<primitive: 123>
	^false!

< aString
	<primitive: 124>
	^self error: 'Not a String'!

> aString
	^aString < self!

<= aString
	^(aString < self) not!

>= aString
	^(self < aString) not!

hash
	<primitive: 125>
	^0! !

!String methodsFor: 'testing'!
isString
	^true!

includesSubstring: aString
	| n |
	n := aString size.
	1 to: self size - n + 1 do: [:i | (self copyFrom: i to: i + n - 1) = aString ifTrue: [^true]].
	^false! !

!String methodsFor: 'converting'!
asSymbol
	<primitive: 122>
	self primitiveFailed!

asString
	^self!

asNumber
	"The number the text reads as, or nil."
	<primitive: 150>
	^nil!

asUppercase
	^self collect: [:c | c asUppercase]!

asLowercase
	^self collect: [:c | c asLowercase]!

displayString
	^self!

species
	^String! !

!String methodsFor: 'printing'!
printOn: aStream
	"'it''s': quoted, a quote doubled"
	aStream nextPut: $'.
	self do: [:c | aStream nextPut: c. c == $' ifTrue: [aStream nextPut: c]].
	aStream nextPut: $'! !

!Symbol class methodsFor: 'instance creation'!
new: anInteger
	^self error: 'Symbols are made by asSymbol, unique'! !

!Symbol methodsFor: 'comparing'!
= anObject
	"Symbols are unique: equal is identical."
	^self == anObject!

hash
	^self identityHash! !

!Symbol methodsFor: 'accessing'!
at: index put: aCharacter
	^self error: 'Symbols cannot be changed'! !

!Symbol methodsFor: 'converting'!
asSymbol
	^self!

asString
	| s |
	s := String new: self size.
	s replaceFrom: 1 to: self size with: self startingAt: 1.
	^s!

numArgs
	| n |
	n := 0.
	self do: [:c | c == $: ifTrue: [n := n + 1]].
	(n = 0 and: [(self at: 1) isLetter not]) ifTrue: [^1].
	^n! !

!Symbol methodsFor: 'testing'!
isSymbol
	^true! !

!Symbol methodsFor: 'printing'!
printOn: aStream
	aStream nextPut: $#; nextPutAll: self!

displayString
	^self asString! !

!Symbol methodsFor: 'copying'!
shallowCopy
	^self! !

!ByteArray methodsFor: 'accessing'!
size
	<primitive: 62>
	^0! !

!Interval class methodsFor: 'instance creation'!
from: start to: stop by: step
	^self new setFrom: start to: stop by: step! !

!Interval methodsFor: 'private'!
setFrom: startNumber to: stopNumber by: stepNumber
	start := startNumber.
	stop := stopNumber.
	step := stepNumber!

species
	^Array! !

!Interval methodsFor: 'accessing'!
size
	step > 0
		ifTrue: [stop < start ifTrue: [^0]]
		ifFalse: [start < stop ifTrue: [^0]].
	^stop - start // step + 1!

at: index
	(index >= 1 and: [index <= self size]) ifTrue: [^start + (step * (index - 1))].
	^self error: 'Index out of bounds'!

at: index put: anObject
	^self error: 'Intervals cannot be changed'! !

!Interval methodsFor: 'enumerating'!
do: aBlock
	| i |
	i := start.
	step > 0
		ifTrue: [[i <= stop] whileTrue: [aBlock value: i. i := i + step]]
		ifFalse: [[i >= stop] whileTrue: [aBlock value: i. i := i + step]]!

collect: aBlock
	| result i |
	result := Array new: self size.
	i := 0.
	self do: [:each | result at: (i := i + 1) put: (aBlock value: each)].
	^result! !

!Interval methodsFor: 'printing'!
printOn: aStream
	aStream nextPut: $(; print: start; nextPutAll: ' to: '; print: stop.
	step = 1 ifFalse: [aStream nextPutAll: ' by: '; print: step].
	aStream nextPut: $)! !

!OrderedCollection class methodsFor: 'instance creation'!
new
	^self new: 8!

new: anInteger
	^(self basicNew: anInteger) setIndices! !

!OrderedCollection methodsFor: 'private'!
setIndices
	firstIndex := self basicSize // 2 max: 1.
	lastIndex := firstIndex - 1!

setFirst: first last: last
	firstIndex := first.
	lastIndex := last!

grow
	"A copy with room at both ends, then become: -- the receiver is the
	bigger one from now on, for whoever holds it."
	| newSelf newFirst n |
	n := self basicSize * 2 + 8.
	newSelf := self class basicNew: n.
	1 to: self class instSize do: [:i | newSelf instVarAt: i put: (self instVarAt: i)].
	newFirst := n - self size // 2 + 1.
	1 to: self size do: [:i | newSelf basicAt: newFirst + i - 1 put: (self basicAt: firstIndex + i - 1)].
	newSelf setFirst: newFirst last: newFirst + self size - 1.
	self become: newSelf! !

!OrderedCollection methodsFor: 'accessing'!
size
	^lastIndex - firstIndex + 1!

at: index
	(index < 1 or: [index > self size]) ifTrue: [^self error: 'Index out of bounds: ', index printString].
	^self basicAt: index + firstIndex - 1!

at: index put: anObject
	(index < 1 or: [index > self size]) ifTrue: [^self error: 'Index out of bounds: ', index printString].
	^self basicAt: index + firstIndex - 1 put: anObject! !

!OrderedCollection methodsFor: 'adding'!
add: anObject
	^self addLast: anObject!

addLast: anObject
	lastIndex = self basicSize ifTrue: [self grow].
	lastIndex := lastIndex + 1.
	^self basicAt: lastIndex put: anObject!

addFirst: anObject
	firstIndex = 1 ifTrue: [self grow].
	firstIndex := firstIndex - 1.
	^self basicAt: firstIndex put: anObject! !

!OrderedCollection methodsFor: 'removing'!
removeFirst
	| answer |
	self isEmpty ifTrue: [^self error: 'Collection is empty'].
	answer := self basicAt: firstIndex.
	self basicAt: firstIndex put: nil.
	firstIndex := firstIndex + 1.
	^answer!

removeLast
	| answer |
	self isEmpty ifTrue: [^self error: 'Collection is empty'].
	answer := self basicAt: lastIndex.
	self basicAt: lastIndex put: nil.
	lastIndex := lastIndex - 1.
	^answer!

remove: oldObject ifAbsent: aBlock
	| index |
	index := firstIndex.
	[index <= lastIndex] whileTrue: [
		oldObject = (self basicAt: index) ifTrue: [
			index to: lastIndex - 1 do: [:i | self basicAt: i put: (self basicAt: i + 1)].
			self basicAt: lastIndex put: nil.
			lastIndex := lastIndex - 1.
			^oldObject].
		index := index + 1].
	^aBlock value! !

!OrderedCollection methodsFor: 'enumerating'!
do: aBlock
	firstIndex to: lastIndex do: [:i | aBlock value: (self basicAt: i)]!

collect: aBlock
	| result |
	result := OrderedCollection new: self size.
	self do: [:each | result addLast: (aBlock value: each)].
	^result!

select: aBlock
	| result |
	result := self copyEmpty.
	self do: [:each | (aBlock value: each) ifTrue: [result add: each]].
	^result!

copyEmpty
	^self class new! !

!OrderedCollection methodsFor: 'copying'!
copyFrom: start to: stop
	| result |
	result := OrderedCollection new.
	start to: stop do: [:i | result addLast: (self at: i)].
	^result!

, aCollection
	^self copy addAll: aCollection; yourself!

copy
	^self collect: [:each | each]!

reversed
	| result |
	result := OrderedCollection new.
	self do: [:each | result addFirst: each].
	^result! !

!SortedCollection class methodsFor: 'instance creation'!
new
	^self sortBlock: [:a :b | a <= b]!

sortBlock: aBlock
	^(self new: 8) setSortBlock: aBlock! !

!SortedCollection methodsFor: 'private'!
setSortBlock: aBlock
	sortBlock := aBlock!

copyEmpty
	^SortedCollection sortBlock: sortBlock! !

!SortedCollection methodsFor: 'adding'!
add: anObject
	"Put at the end, then moved down past the ones it sorts before:
	an insertion sort, one element at a time."
	| i |
	self addLast: anObject.
	i := lastIndex.
	[i > firstIndex and: [sortBlock value: anObject value: (self basicAt: i - 1)]] whileTrue: [
		self basicAt: i put: (self basicAt: i - 1).
		i := i - 1].
	self basicAt: i put: anObject.
	^anObject!

addFirst: anObject
	^self shouldNotImplement!

at: index put: anObject
	^self shouldNotImplement! !

!SortedCollection methodsFor: 'accessing'!
sortBlock
	^sortBlock!

median
	^self at: self size + 1 // 2! !

!SortedCollection methodsFor: 'enumerating'!
collect: aBlock
	"The answers are not sorted: an OrderedCollection."
	| result |
	result := OrderedCollection new: self size.
	self do: [:each | result addLast: (aBlock value: each)].
	^result! !

!Set class methodsFor: 'instance creation'!
new
	^self new: 16!

new: anInteger
	^(self basicNew: anInteger) setTally! !

!Set methodsFor: 'private'!
setTally
	tally := 0!

findIndexFor: anObject
	"Where anObject is, or the empty slot where it would go: its hash,
	then the next slots in turn (open addressing)."
	| index element |
	index := anObject hash \\ self basicSize + 1.
	[element := self basicAt: index.
	element == nil or: [self matches: element key: anObject]]
		whileFalse: [index := index \\ self basicSize + 1].
	^index!

matches: element key: anObject
	^element = anObject!

grow
	| newSelf |
	newSelf := self class new: self basicSize * 2.
	"the slots themselves: a Dictionary's do: gives its values"
	1 to: self basicSize do: [:i |
		(self basicAt: i) == nil ifFalse: [newSelf noCheckAdd: (self basicAt: i)]].
	self become: newSelf!

noCheckAdd: anObject
	self basicAt: (self findIndexFor: (self keyOf: anObject)) put: anObject.
	tally := tally + 1!

keyOf: element
	^element! !

!Set methodsFor: 'accessing'!
size
	^tally! !

!Set methodsFor: 'adding'!
add: newObject
	| index |
	newObject == nil ifTrue: [^newObject].
	index := self findIndexFor: newObject.
	(self basicAt: index) == nil ifTrue: [
		self basicAt: index put: newObject.
		tally := tally + 1.
		tally * 4 > (self basicSize * 3) ifTrue: [self grow]].
	^newObject! !

!Set methodsFor: 'removing'!
remove: oldObject ifAbsent: aBlock
	| index rest |
	index := self findIndexFor: oldObject.
	(self basicAt: index) == nil ifTrue: [^aBlock value].
	self basicAt: index put: nil.
	tally := tally - 1.
	"the ones after it, in its run, put again"
	rest := OrderedCollection new.
	index := index \\ self basicSize + 1.
	[(self basicAt: index) == nil] whileFalse: [
		rest add: (self basicAt: index).
		self basicAt: index put: nil.
		tally := tally - 1.
		index := index \\ self basicSize + 1].
	rest do: [:each | self noCheckAdd: each].
	^oldObject! !

!Set methodsFor: 'testing'!
includes: anObject
	^(self basicAt: (self findIndexFor: anObject)) ~~ nil! !

!Set methodsFor: 'enumerating'!
do: aBlock
	1 to: self basicSize do: [:i | | each | each := self basicAt: i. each == nil ifFalse: [aBlock value: each]]! !

!Dictionary methodsFor: 'private'!
matches: element key: aKey
	^element key = aKey!

keyOf: element
	^element key! !

!Dictionary methodsFor: 'accessing'!
at: key
	^self at: key ifAbsent: [self error: 'Key not found: ', key printString]!

at: key ifAbsent: aBlock
	| assoc |
	assoc := self basicAt: (self findIndexFor: key).
	assoc == nil ifTrue: [^aBlock value].
	^assoc value!

at: key put: value
	| index assoc |
	index := self findIndexFor: key.
	assoc := self basicAt: index.
	assoc == nil
		ifTrue: [
			self basicAt: index put: (Association key: key value: value).
			tally := tally + 1.
			tally * 4 > (self basicSize * 3) ifTrue: [self grow]]
		ifFalse: [assoc value: value].
	^value!

associationAt: key
	^self basicAt: (self findIndexFor: key)!

keys
	| result |
	result := Set new.
	self associationsDo: [:assoc | result add: assoc key].
	^result!

values
	| result |
	result := OrderedCollection new.
	self do: [:value | result add: value].
	^result!

keyAtValue: value
	self associationsDo: [:assoc | assoc value = value ifTrue: [^assoc key]].
	^nil! !

!Dictionary methodsFor: 'adding'!
add: anAssociation
	self at: anAssociation key put: anAssociation value.
	^anAssociation! !

!Dictionary methodsFor: 'removing'!
removeKey: key
	^self removeKey: key ifAbsent: [self error: 'Key not found']!

removeKey: key ifAbsent: aBlock
	| assoc |
	assoc := self basicAt: (self findIndexFor: key).
	assoc == nil ifTrue: [^aBlock value].
	super remove: key ifAbsent: [].
	^assoc value! !

!Dictionary methodsFor: 'testing'!
includesKey: key
	^(self basicAt: (self findIndexFor: key)) ~~ nil!

includes: value
	self do: [:each | each = value ifTrue: [^true]].
	^false! !

!Dictionary methodsFor: 'enumerating'!
associationsDo: aBlock
	super do: aBlock!

do: aBlock
	self associationsDo: [:assoc | aBlock value: assoc value]!

keysDo: aBlock
	self associationsDo: [:assoc | aBlock value: assoc key]!

keysAndValuesDo: aBlock
	self associationsDo: [:assoc | aBlock value: assoc key value: assoc value]!

collect: aBlock
	| result |
	result := Bag new.
	self do: [:each | result add: (aBlock value: each)].
	^result!

select: aBlock
	| result |
	result := Dictionary new.
	self associationsDo: [:assoc | (aBlock value: assoc value) ifTrue: [result add: assoc]].
	^result! !

!Dictionary methodsFor: 'printing'!
printOn: aStream
	aStream nextPutAll: self class name; nextPutAll: ' ('.
	self associationsDo: [:assoc | aStream print: assoc; space].
	aStream nextPut: $)! !

!Bag class methodsFor: 'instance creation'!
new
	^self basicNew setContents! !

!Bag methodsFor: 'private'!
setContents
	contents := Dictionary new! !

!Bag methodsFor: 'adding'!
add: newObject
	^self add: newObject withOccurrences: 1!

add: newObject withOccurrences: anInteger
	contents at: newObject put: (contents at: newObject ifAbsent: [0]) + anInteger.
	^newObject! !

!Bag methodsFor: 'removing'!
remove: oldObject ifAbsent: aBlock
	| count |
	count := contents at: oldObject ifAbsent: [^aBlock value].
	count = 1
		ifTrue: [contents removeKey: oldObject]
		ifFalse: [contents at: oldObject put: count - 1].
	^oldObject! !

!Bag methodsFor: 'accessing'!
size
	| tally |
	tally := 0.
	contents do: [:count | tally := tally + count].
	^tally!

occurrencesOf: anObject
	^contents at: anObject ifAbsent: [0]! !

!Bag methodsFor: 'enumerating'!
do: aBlock
	contents associationsDo: [:assoc | assoc value timesRepeat: [aBlock value: assoc key]]! !
|st});
("Streams.st", {st|"Streams over collections: printString is printOn: into a WriteStream
on a String, and a ReadStream reads one element at a time."!

!Stream methodsFor: 'accessing'!
next
	^self subclassResponsibility!

nextPut: anObject
	^self subclassResponsibility!

nextPutAll: aCollection
	aCollection do: [:each | self nextPut: each].
	^aCollection!

atEnd
	^self subclassResponsibility!

do: aBlock
	[self atEnd] whileFalse: [aBlock value: self next]! !

!Stream methodsFor: 'printing'!
print: anObject
	anObject printOn: self!

cr
	self nextPut: Character cr!

tab
	self nextPut: Character tab!

space
	self nextPut: Character space! !

!PositionableStream class methodsFor: 'instance creation'!
on: aCollection
	^self basicNew on: aCollection! !

!PositionableStream methodsFor: 'private'!
on: aCollection
	collection := aCollection.
	readLimit := aCollection size.
	position := 0! !

!PositionableStream methodsFor: 'accessing'!
contents
	^collection copyFrom: 1 to: readLimit!

position
	^position!

position: anInteger
	position := anInteger!

reset
	position := 0!

isEmpty
	^readLimit = 0!

atEnd
	^position >= readLimit!

peek
	self atEnd ifTrue: [^nil].
	^collection at: position + 1!

skip: anInteger
	position := (position + anInteger min: readLimit) max: 0!

upTo: anObject
	| start |
	start := position + 1.
	[self atEnd or: [self next = anObject]] whileFalse.
	^collection copyFrom: start to: (self atEnd ifTrue: [position] ifFalse: [position - 1])!

upToEnd
	| start |
	start := position + 1.
	position := readLimit.
	^collection copyFrom: start to: readLimit!

skipSeparators
	[self atEnd not and: [self peek isSeparator]] whileTrue: [self next]! !

!ReadStream methodsFor: 'accessing'!
next
	self atEnd ifTrue: [^nil].
	position := position + 1.
	^collection at: position!

nextPut: anObject
	^self shouldNotImplement! !

!WriteStream class methodsFor: 'instance creation'!
with: aCollection
	^(self on: aCollection) setToEnd! !

!WriteStream methodsFor: 'private'!
on: aCollection
	super on: aCollection.
	readLimit := 0.
	writeLimit := aCollection size!

setToEnd
	position := readLimit := writeLimit!

growCollection
	| bigger |
	bigger := collection species new: collection size * 2 + 16.
	bigger replaceFrom: 1 to: collection size with: collection startingAt: 1.
	collection := bigger.
	writeLimit := collection size! !

!WriteStream methodsFor: 'accessing'!
nextPut: anObject
	position >= writeLimit ifTrue: [self growCollection].
	position := position + 1.
	collection at: position put: anObject.
	position > readLimit ifTrue: [readLimit := position].
	^anObject!

contents
	^collection copyFrom: 1 to: position!

next
	^self shouldNotImplement! !

!ReadWriteStream methodsFor: 'accessing'!
next
	self atEnd ifTrue: [^nil].
	position := position + 1.
	^collection at: position!

contents
	^collection copyFrom: 1 to: readLimit! !

!SequenceableCollection methodsFor: 'converting'!
writeStream
	^WriteStream on: self! !
|st});
("Graphics.st", {st|"The display, as the Blue Book's chapters 18 to 20 have it: Forms,
pictures of one bit per pixel; BitBlt, the one primitive that draws
them (St_bitblt.mli); and Pen, a turtle that draws lines with it,
Logo's idea brought to Smalltalk (Papert and Kay were friends).
Display is the Form of the screen: what a Pen draws there is drawn over
the windows, until the screen menu's 'restore display' erases it."!

!Form class methodsFor: 'instance creation'!
extent: aPoint
	^self width: aPoint x height: aPoint y!

width: w height: h
	^self new setBits: (ByteArray new: w + 15 // 16 * 2 * h) width: w height: h! !

!Form methodsFor: 'private'!
setBits: aByteArray width: w height: h
	bits := aByteArray.
	width := w.
	height := h! !

!Form methodsFor: 'accessing'!
width
	^width!

height
	^height!

extent
	^width @ height!

boundingBox
	^0 @ 0 corner: width @ height!

center
	^(width // 2) @ (height // 2)!

bits
	^bits! !

!Form methodsFor: 'displaying'!
fill: aRectangle rule: anInteger
	(BitBlt destForm: self sourceForm: nil halftoneForm: nil combinationRule: anInteger
		destOrigin: aRectangle origin sourceOrigin: 0 @ 0 extent: aRectangle extent clipRect: self boundingBox) copyBits!

fillWhite
	self fill: self boundingBox rule: 0!

fillBlack
	self fill: self boundingBox rule: 15!

reverse
	self fill: self boundingBox rule: 10!

displayOn: aForm at: aPoint rule: anInteger
	(BitBlt destForm: aForm sourceForm: self halftoneForm: nil combinationRule: anInteger
		destOrigin: aPoint sourceOrigin: 0 @ 0 extent: self extent clipRect: aForm boundingBox) copyBits!

displayAt: aPoint
	self displayOn: Display at: aPoint rule: 3!

pixelAt: aPoint
	"0 or 1, read the BitBlt way: the pixel copied onto a Form of one."
	| one |
	one := Form width: 1 height: 1.
	(BitBlt destForm: one sourceForm: self halftoneForm: nil combinationRule: 3
		destOrigin: 0 @ 0 sourceOrigin: aPoint extent: 1 @ 1 clipRect: one boundingBox) copyBits.
	^(one bits at: 1) bitShift: -7! !

!Form methodsFor: 'printing'!
printOn: aStream
	aStream nextPutAll: 'a Form('; print: width; nextPut: $x; print: height; nextPut: $)! !

!BitBlt class methodsFor: 'instance creation'!
destForm: df sourceForm: sf halftoneForm: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect
	^self new
		setDestForm: df sourceForm: sf halftoneForm: hf combinationRule: cr
		destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect! !

!BitBlt methodsFor: 'private'!
setDestForm: df sourceForm: sf halftoneForm: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect
	destForm := df.
	sourceForm := sf.
	halftoneForm := hf.
	combinationRule := cr.
	destX := destOrigin x.
	destY := destOrigin y.
	sourceX := sourceOrigin x.
	sourceY := sourceOrigin y.
	width := extent x.
	height := extent y.
	clipX := clipRect origin x.
	clipY := clipRect origin y.
	clipWidth := clipRect width.
	clipHeight := clipRect height! !

!BitBlt methodsFor: 'accessing'!
destForm: aForm
	destForm := aForm!

sourceForm: aForm
	sourceForm := aForm!

halftoneForm: aForm
	halftoneForm := aForm!

combinationRule: anInteger
	combinationRule := anInteger!

destOrigin: aPoint
	destX := aPoint x.
	destY := aPoint y!

destX: x destY: y
	destX := x.
	destY := y!

width: w height: h
	width := w.
	height := h!

clipRect: aRectangle
	clipX := aRectangle origin x.
	clipY := aRectangle origin y.
	clipWidth := aRectangle width.
	clipHeight := aRectangle height! !

!BitBlt methodsFor: 'copying'!
copyBits
	"The one drawing primitive (St_bitblt.mli)."
	<primitive: 96>
	^self error: 'Bad BitBlt arguments'! !

!Pen class methodsFor: 'instance creation'!
new
	"A pen of one pixel on the Display, at its center, pointing up."
	^super new defaultNib: 1! !

!Pen methodsFor: 'initialize'!
defaultNib: n
	destForm := Display.
	sourceForm := (Form width: n height: n) fillBlack; yourself.
	combinationRule := 7.
	width := n.
	height := n.
	sourceX := 0.
	sourceY := 0.
	self clipRect: Display boundingBox.
	frame := Display boundingBox.
	location := Display center.
	direction := 270.
	penDown := true! !

!Pen methodsFor: 'accessing'!
location
	^location!

direction
	^direction! !

!Pen methodsFor: 'moving'!
up
	penDown := false!

down
	penDown := true!

turn: degrees
	"Clockwise, the y axis going down."
	direction := direction + degrees \\ 360!

north
	direction := 270!

home
	location := Display center!

place: aPoint
	location := aPoint!

go: distance
	"Forward, drawing if the pen is down."
	| old radians |
	old := location.
	radians := direction degreesToRadians.
	location := location + ((radians cos * distance) @ (radians sin * distance)).
	penDown ifTrue: [self drawFrom: old to: location]!

goto: aPoint
	| old |
	old := location.
	location := aPoint.
	penDown ifTrue: [self drawFrom: old to: location]!

drawFrom: startPoint to: endPoint
	"Bresenham's line (1965), a copyBits of the nib at each point:
	the error term says when to step across as well as along."
	| x0 y0 x1 y1 dx dy sx sy err e2 |
	x0 := startPoint x rounded.
	y0 := startPoint y rounded.
	x1 := endPoint x rounded.
	y1 := endPoint y rounded.
	dx := (x1 - x0) abs.
	dy := (y1 - y0) abs negated.
	sx := x0 < x1 ifTrue: [1] ifFalse: [-1].
	sy := y0 < y1 ifTrue: [1] ifFalse: [-1].
	err := dx + dy.
	[destX := x0.
	destY := y0.
	self copyBits.
	x0 = x1 and: [y0 = y1]] whileFalse: [
		e2 := 2 * err.
		e2 >= dy ifTrue: [err := err + dy. x0 := x0 + sx].
		e2 <= dx ifTrue: [err := err + dx. y0 := y0 + sy]]! !

!Pen methodsFor: 'geometric designs'!
dragon: n
	"The dragon curve, the Blue Book's (chapter 20): Pen new dragon: 9."
	n = 0
		ifTrue: [self go: 10]
		ifFalse: [
			n > 0
				ifTrue: [self dragon: n - 1; turn: 90; dragon: 1 - n]
				ifFalse: [self dragon: -1 - n; turn: -90; dragon: 1 + n]]!

spiral: n angle: a
	"Pen new spiral: 200 angle: 89."
	1 to: n do: [:i | self go: i; turn: a]!

polygon: sides length: length
	sides timesRepeat: [self go: length; turn: 360 // sides]!

scribble
	"Pen new scribble: press the button and draw, release to stop --
	the mouse read by Smalltalk while it runs."
	self place: Sensor waitButton.
	[Sensor anyButtonPressed] whileTrue: [self goto: Sensor mousePoint]! !

!Number methodsFor: 'converting'!
degreesToRadians
	^self asFloat * 0.017453292519943295! !

!InputSensor methodsFor: 'mouse'!
mousePoint
	"Where the mouse is, on the Display."
	<primitive: 90>
	self primitiveFailed!

cursorPoint
	^self mousePoint!

buttons
	<primitive: 91>
	self primitiveFailed!

redButtonPressed
	^(self buttons bitAnd: 4) ~= 0!

yellowButtonPressed
	^(self buttons bitAnd: 2) ~= 0!

blueButtonPressed
	^(self buttons bitAnd: 1) ~= 0!

anyButtonPressed
	^self buttons ~= 0!

waitButton
	[self anyButtonPressed] whileFalse.
	^self mousePoint!

waitNoButton
	[self anyButtonPressed] whileTrue! !
|st});
("System.st", {st|"The last chunks the bootstrap runs, once every method is compiled:
the globals that are objects rather than classes."!

Smalltalk at: #Transcript put: TextCollector new!

Smalltalk at: #Display put: (Form extent: 800 @ 600)!

Smalltalk at: #Sensor put: InputSensor new!

Rectangle comment: 'A rectangle of the screen, from its origin (top left) to its corner (bottom right), each a Point.'!

Point comment: 'A point of the screen, x to the right and y downwards: 3@4.'!

Object comment: 'The root of the classes: what every object answers.'!
|st});
]
let squeak = files @ [
("squeak/Closures.st", {st|"Squeak's kernel, the first file: the blocks. A kernel that defines
BlockClosure is compiled with closures (St_compile.mli): a block is no
longer a BlockContext sharing its method's temporaries but a
BlockClosure, an object holding what it needs from outside, and each
value of it runs in a context of its own. So a block can call itself,
and two blocks made by the same code do not share their arguments.

MethodContext's unused field gets its Squeak name: the closure a
context is running, nil for a method's."!

Object variableSubclass: #BlockClosure
	instanceVariableNames: 'outerContext startpc numArgs'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!

ContextPart variableSubclass: #MethodContext
	instanceVariableNames: 'method closureOrNil receiver'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!

!BlockClosure methodsFor: 'accessing'!
outerContext
	^outerContext!

home
	^outerContext home!

method
	^outerContext method!

receiver
	^outerContext receiver!

numArgs
	^numArgs!

numCopiedValues
	^self size! !

!BlockClosure methodsFor: 'evaluating'!
value
	"Evaluate the block, in a new context: the virtual machine makes
	a MethodContext whose closure is the receiver (St_interp.mli)."
	<primitive: 81>
	^self error: 'Wrong number of arguments'!

value: arg
	<primitive: 81>
	^self error: 'Wrong number of arguments'!

value: arg1 value: arg2
	<primitive: 81>
	^self error: 'Wrong number of arguments'!

value: arg1 value: arg2 value: arg3
	<primitive: 81>
	^self error: 'Wrong number of arguments'!

value: arg1 value: arg2 value: arg3 value: arg4
	<primitive: 81>
	^self error: 'Wrong number of arguments'!

valueWithArguments: anArray
	<primitive: 82>
	^self error: 'Wrong number of arguments'! !

!BlockClosure methodsFor: 'controlling'!
whileTrue: aBlock
	"Sent only when the compiler could not inline it."
	[self value] whileTrue: [aBlock value].
	^nil!

whileFalse: aBlock
	[self value] whileFalse: [aBlock value].
	^nil!

whileTrue
	[self value] whileTrue.
	^nil!

repeat
	[true] whileTrue: [self value]! !

!BlockClosure methodsFor: 'printing'!
printOn: aStream
	aStream nextPutAll: '[] in '.
	self home printOn: aStream! !

!MethodContext methodsFor: 'accessing'!
closure
	^closureOrNil!

home
	"The context of the method a block's ^ returns from: for a
	closure's activation, up its outer contexts."
	^closureOrNil == nil ifTrue: [self] ifFalse: [closureOrNil home]! !

!MethodContext methodsFor: 'printing'!
printOn: aStream
	| mclass |
	closureOrNil == nil ifFalse: [aStream nextPutAll: '[] in '].
	mclass := method methodClass.
	aStream nextPutAll: receiver class name.
	mclass == receiver class ifFalse: [aStream nextPut: $(; nextPutAll: mclass name; nextPut: $)].
	aStream nextPutAll: '>>'; nextPutAll: method selector! !
|st});
]
let mini_morphic = squeak @ [
("morphic/MiniMorphic.st", {st|"MiniMorphic: Morphic in one file, to read before the real one.

Morphic (John Maloney and Randall Smith, for Self, 1995; Squeak's
since 1997) has few ideas, all here:

- everything on the screen is a Morph: a rectangle of it, a colour,
  an owner and submorphs. The screen itself is one, the world; so is
  the hand, the mouse made visible, and what it carries are its
  submorphs;
- a morph is alive: the world sends step to every morph, every cycle,
  and a morph that wants to move just changes its position;
- nobody redraws: a morph that changed says where (changed), the
  world remembers those rectangles (its damage), and at the end of
  the cycle redraws only them, back to front, clipped;
- the cycle is the whole program: read the mouse, step, redraw.

What is left out is what makes Squeak's Morphic big, not different:
text, menus, halos, layout, events for the keyboard, colours (the
Display here has one bit a pixel: black, white, and two grays made of
both). The classes: Canvas (a Form to draw on, through one BitBlt),
Morph, AtomMorph (a morph that bounces: the demo), HandMorph,
WorldMorph. The interpreter knows none of them: all it gives is
BitBlt, the mouse and the clock (St_bitblt.mli, St_primitives.mli)."!

Object subclass: #Canvas
	instanceVariableNames: 'form blt clip'
	classVariableNames: 'Gray LightGray'
	poolDictionaries: ''
	category: 'MiniMorphic'!

Object subclass: #Morph
	instanceVariableNames: 'bounds owner submorphs color'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MiniMorphic'!

Morph subclass: #AtomMorph
	instanceVariableNames: 'velocity'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MiniMorphic'!

Morph subclass: #HandMorph
	instanceVariableNames: 'wasDown'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MiniMorphic'!

Morph subclass: #WorldMorph
	instanceVariableNames: 'hand canvas damage'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MiniMorphic'!

!Rectangle methodsFor: 'morphic'!
left
	^origin x!

top
	^origin y!

right
	^corner x!

bottom
	^corner y!

translateBy: aPoint
	^Rectangle origin: origin + aPoint corner: corner + aPoint!

insetBy: anInteger
	"Smaller by that much on every side."
	^Rectangle origin: origin + anInteger corner: corner - anInteger!

intersects: aRectangle
	"The kernel's, in four comparisons of numbers and no Point made:
	it is asked of every morph for every rectangle redrawn."
	^origin x < aRectangle corner x
		and: [aRectangle origin x < corner x
		and: [origin y < aRectangle corner y
		and: [aRectangle origin y < corner y]]]!

intersect: aRectangle
	"What the two have in common; empty (no width) if nothing."
	^Rectangle origin: (origin max: aRectangle origin) corner: (corner min: aRectangle corner)!

merge: aRectangle
	"The smallest rectangle holding both."
	^Rectangle origin: (origin min: aRectangle origin) corner: (corner max: aRectangle corner)! !

!Canvas class methodsFor: 'instance creation'!
on: aForm
	^self new setForm: aForm! !

!Canvas class methodsFor: 'patterns'!
pattern: evenByte with: oddByte
	"A halftone (St_bitblt.mli): 16 by 16, its even rows of one byte,
	its odd rows of another."
	| f |
	f := Form extent: 16 @ 16.
	1 to: 32 do: [:i | f bits at: i put: (i - 1 // 2 \\ 2 = 0 ifTrue: [evenByte] ifFalse: [oddByte])].
	^f!

gray
	Gray == nil ifTrue: [Gray := self pattern: 16rAA with: 16r55].
	^Gray!

lightGray
	LightGray == nil ifTrue: [LightGray := self pattern: 16r88 with: 16r22].
	^LightGray! !

!Canvas methodsFor: 'private'!
setForm: aForm
	form := aForm.
	clip := aForm boundingBox.
	blt := BitBlt destForm: aForm sourceForm: nil halftoneForm: nil combinationRule: 3
		destOrigin: 0 @ 0 sourceOrigin: 0 @ 0 extent: 0 @ 0 clipRect: clip! !

!Canvas methodsFor: 'clipping'!
clip
	^clip!

clip: aRectangle
	"Nothing is drawn outside it, whatever is asked: how the world
	redraws one rectangle of the screen and no more."
	clip := aRectangle.
	blt clipRect: aRectangle! !

!Canvas methodsFor: 'drawing'!
fill: aRectangle color: aSymbol
	"One BitBlt with no source: the rule alone for black (15: ones) and
	white (0: zeros), a halftone stored (3) for the grays."
	aSymbol == #black
		ifTrue: [blt halftoneForm: nil; combinationRule: 15]
		ifFalse: [aSymbol == #white
			ifTrue: [blt halftoneForm: nil; combinationRule: 0]
			ifFalse: [blt halftoneForm: (aSymbol == #gray ifTrue: [Canvas gray] ifFalse: [Canvas lightGray]); combinationRule: 3]].
	blt destX: aRectangle left destY: aRectangle top; width: aRectangle width height: aRectangle height.
	blt copyBits! !

!Morph class methodsFor: 'instance creation'!
new
	^super new initialize! !

!Morph methodsFor: 'initialize'!
initialize
	bounds := 0 @ 0 corner: 50 @ 40.
	submorphs := OrderedCollection new.
	color := #gray! !

!Morph methodsFor: 'accessing'!
bounds
	^bounds!

position
	^bounds origin!

extent
	^bounds extent!

color
	^color!

owner
	^owner!

submorphs
	^submorphs!

world
	"The morph at the top, if it is a world: a morph in nobody's hands
	and on no screen has none."
	^owner == nil ifTrue: [nil] ifFalse: [owner world]! !

!Morph methodsFor: 'changing'!
color: aSymbol
	color := aSymbol.
	self changed!

extent: aPoint
	self changed.
	bounds := bounds origin extent: aPoint.
	self changed!

position: aPoint
	"Move, with all it holds. The place left and the place taken both
	changed."
	| delta |
	delta := aPoint - bounds origin.
	(delta x = 0 and: [delta y = 0]) ifTrue: [^self].
	self changed.
	self privateMoveBy: delta.
	self changed!

privateMoveBy: delta
	bounds := bounds translateBy: delta.
	submorphs do: [:m | m privateMoveBy: delta]!

changed
	"All a morph does about the screen: say where it is no longer
	right. Its submorphs may stick out of it."
	self invalidRect: bounds.
	submorphs do: [:m | m changed]!

invalidRect: aRectangle
	"Up to the world, which keeps it."
	owner == nil ifFalse: [owner invalidRect: aRectangle]! !

!Morph methodsFor: 'submorphs'!
addMorph: aMorph
	"In front of the others: the first submorph is the frontmost."
	aMorph delete.
	submorphs addFirst: aMorph.
	aMorph privateOwner: self.
	aMorph changed!

delete
	"Out of its owner, off the screen."
	owner == nil ifTrue: [^self].
	self changed.
	owner submorphs remove: self.
	owner := nil!

privateOwner: aMorph
	owner := aMorph!

morphAt: aPoint
	"The frontmost morph there: a submorph before its owner, the first
	submorph before the others."
	submorphs do: [:m | | found |
		found := m morphAt: aPoint.
		found == nil ifFalse: [^found]].
	^(bounds containsPoint: aPoint) ifTrue: [self] ifFalse: [nil]! !

!Morph methodsFor: 'drawing'!
drawOn: aCanvas
	"What a morph looks like: the one method a new kind of morph
	writes."
	aCanvas fill: bounds color: #black.
	aCanvas fill: (bounds insetBy: 1) color: color!

fullDrawOn: aCanvas
	"Itself, then what it holds, the frontmost last. A morph outside
	the canvas's clipping rectangle is not drawn at all."
	(bounds intersects: aCanvas clip) ifTrue: [self drawOn: aCanvas].
	submorphs reverseDo: [:m | m fullDrawOn: aCanvas]! !

!Morph methodsFor: 'stepping'!
step
	"Sent every cycle. A morph that does something by itself does it
	here."!

fullStep
	self step.
	submorphs do: [:m | m fullStep]! !

!AtomMorph methodsFor: 'initialize'!
initialize
	super initialize.
	bounds := 0 @ 0 corner: 12 @ 12.
	velocity := 3 @ 2! !

!AtomMorph methodsFor: 'accessing'!
velocity
	^velocity!

velocity: aPoint
	velocity := aPoint! !

!AtomMorph methodsFor: 'stepping'!
step
	"Move by the velocity, and turn back at the owner's walls. In the
	hand, be still."
	| box p vx vy |
	(owner isKindOf: HandMorph) ifTrue: [^self].
	box := owner bounds.
	vx := velocity x.
	vy := velocity y.
	p := bounds origin + velocity.
	(p x < box left or: [p x + bounds width > box right]) ifTrue: [vx := vx negated].
	(p y < box top or: [p y + bounds height > box bottom]) ifTrue: [vy := vy negated].
	velocity := vx @ vy.
	self position: bounds origin + velocity! !

!HandMorph methodsFor: 'initialize'!
initialize
	super initialize.
	bounds := 0 @ 0 corner: 8 @ 8.
	color := #black.
	wasDown := false! !

!HandMorph methodsFor: 'events'!
processEvents
	"The mouse read once a cycle: the hand goes where it is, with what
	it carries; the button going down picks up the morph under it, the
	button going up puts it down, in front."
	| p down |
	p := Sensor mousePoint.
	down := Sensor redButtonPressed.
	self position: p.
	(down and: [wasDown not]) ifTrue: [self grab: (owner morphAt: p)].
	(down not and: [wasDown]) ifTrue: [self dropAll].
	wasDown := down!

grab: aMorph
	(aMorph == nil or: [aMorph == owner]) ifTrue: [^self].
	self addMorph: aMorph!

dropAll
	submorphs copy do: [:m | owner addMorph: m]! !

!WorldMorph class methodsFor: 'instance creation'!
on: aForm
	^self new setForm: aForm! !

!WorldMorph methodsFor: 'initialize'!
setForm: aForm
	bounds := aForm boundingBox.
	color := #white.
	canvas := Canvas on: aForm.
	damage := OrderedCollection new.
	hand := HandMorph new.
	hand privateOwner: self.
	self invalidRect: bounds! !

!WorldMorph methodsFor: 'accessing'!
world
	^self!

hand
	^hand!

damage
	^damage! !

!WorldMorph methodsFor: 'submorphs'!
morphAt: aPoint
	"A morph of the world, never the world itself."
	| found |
	found := super morphAt: aPoint.
	^found == self ifTrue: [nil] ifFalse: [found]! !

!WorldMorph methodsFor: 'damage'!
invalidRect: aRectangle
	"Remember a rectangle to redraw. Nothing clever here: this is sent
	twice for every morph that moves."
	damage add: aRectangle!

damageToRedraw
	"The rectangles to redraw this cycle, and none remembered after.
	A few (one morph dragged): each of them, and what did not change
	is not touched. Many (everything moving): the one rectangle that
	holds them all, drawn once -- going through the morphs for each of
	a hundred small rectangles costs more than drawing them all."
	| rects all |
	rects := damage.
	damage := OrderedCollection new.
	rects size <= 8 ifTrue: [^rects].
	all := rects first.
	rects do: [:r | all := all merge: r].
	^OrderedCollection new add: all; yourself! !

!WorldMorph methodsFor: 'stepping'!
doOneCycle
	"The whole of Morphic's main loop."
	hand processEvents.
	submorphs copy do: [:m | m fullStep].
	self displayWorld!

displayWorld
	"Each damaged rectangle: the background, then every morph, back to
	front, the hand last -- the canvas clipped to the rectangle, so
	that what did not change is not touched."
	self damageToRedraw do: [:r | | clip |
		clip := r intersect: bounds.
		canvas clip: clip.
		canvas fill: clip color: color.
		submorphs reverseDo: [:m | m fullDrawOn: canvas].
		hand fullDrawOn: canvas]! !

!WorldMorph class methodsFor: 'examples'!
bouncingAtoms: n
	"The classic first demo: n atoms in a box. Each cycle moves them
	all, and redraws only where they were and where they are.
	(WorldMorph bouncingAtoms: 50) doOneCycle"
	| world |
	world := self on: Display.
	1 to: n do: [:i | | atom |
		atom := AtomMorph new.
		atom color: (#(#black #gray #lightGray) at: i \\ 3 + 1).
		atom velocity: (i \\ 7 - 3 * 2 + 1) @ (i \\ 5 - 2 * 2 + 1).
		world addMorph: atom.
		atom position: (i * 37 \\ (world bounds width - 20)) @ (i * 53 \\ (world bounds height - 20))].
	^world! !
|st});
]