'From etoys3.0 of 24 February 2008 [latest update: #1896] on 24 February 2008 at 2:15:30 am'!
Exception subclass: #Abort
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Kernel'!

!Abort methodsFor: 'as yet unclassified' stamp: 'ajh 3/24/2003 00:55'!
defaultAction
	"No one has handled this error, but now give them a chance to decide how to debug it.  If none handle this either then open debugger (see UnhandedError-defaultAction)"

	UnhandledError signalForException: self! !
Object subclass: #AbstractEvent
	instanceVariableNames: 'item itemKind environment'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Change Notification'!

!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:10'!
changeKind

	^self class changeKind! !

!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:43'!
environmentAt: anItemKind

	(self itemKind = anItemKind) ifTrue: [^self item].
	^environment at: anItemKind ifAbsent: [nil]! !

!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:20'!
eventSelector

	^self class eventSelectorBlock value: itemKind value: self changeKind! !

!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:36'!
item: anItem kind: anItemKind

	item := anItem.
	itemKind := anItemKind.
	environment := Dictionary new! !

!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:37'!
itemCategory: aCategory

	environment at: self class categoryKind put: aCategory! !

!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:36'!
itemClass: aClass

	environment at: self class classKind put: aClass! !

!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/14/2003 12:11'!
itemExpression: anExpression

	environment at: self class expressionKind put: anExpression! !

!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:38'!
itemMethod: aMethod

	environment at: self class methodKind put: aMethod! !

!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:38'!
itemProtocol: aProtocol

	environment at: self class protocolKind put: aProtocol! !

!AbstractEvent methodsFor: 'private-accessing' stamp: 'NS 1/27/2004 10:38'!
itemRequestor: requestor

	environment at: #requestor put: requestor! !

!AbstractEvent methodsFor: 'private-accessing' stamp: 'NS 1/27/2004 10:39'!
itemSelector: aSymbol

	environment at: #selector put: aSymbol! !


!AbstractEvent methodsFor: 'accessing' stamp: 'rw 6/30/2003 08:22'!
item
	"Return the item that triggered the event (typically the name of a class, a category, a protocol, a method)."

	^item! !

!AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:43'!
itemCategory

	^self environmentAt: self class categoryKind! !

!AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:43'!
itemClass

	^self environmentAt: self class classKind! !

!AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/14/2003 12:10'!
itemExpression

	^self environmentAt: self class expressionKind! !

!AbstractEvent methodsFor: 'accessing' stamp: 'rw 6/30/2003 08:22'!
itemKind
	"Return the kind of the item of the event (#category, #class, #protocol, #method, ...)"

	^itemKind! !

!AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:44'!
itemMethod

	^self environmentAt: self class methodKind! !

!AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:44'!
itemProtocol

	^self environmentAt: self class protocolKind! !

!AbstractEvent methodsFor: 'accessing' stamp: 'NS 1/27/2004 10:38'!
itemRequestor

	^self environmentAt: #requestor! !

!AbstractEvent methodsFor: 'accessing' stamp: 'NS 1/27/2004 10:38'!
itemSelector

	^self environmentAt: #selector! !


!AbstractEvent methodsFor: 'printing' stamp: 'NS 1/19/2004 17:52'!
printOn: aStream

	self printEventKindOn: aStream.
	aStream
		nextPutAll: ' Event for item: ';
		print: self item;
		nextPutAll: ' of kind: ';
		print: self itemKind! !


!AbstractEvent methodsFor: 'testing' stamp: 'rw 6/30/2003 08:34'!
isAdded

	^false! !

!AbstractEvent methodsFor: 'testing' stamp: 'NS 1/19/2004 18:41'!
isCategoryKnown

	^self itemCategory notNil! !

!AbstractEvent methodsFor: 'testing' stamp: 'rw 7/10/2003 15:01'!
isCommented

	^false! !

!AbstractEvent methodsFor: 'testing' stamp: 'rw 7/14/2003 10:15'!
isDoIt

	^false! !

!AbstractEvent methodsFor: 'testing' stamp: 'NS 1/19/2004 15:09'!
isModified

	^false! !

!AbstractEvent methodsFor: 'testing' stamp: 'NS 1/21/2004 09:40'!
isProtocolKnown

	^self itemCategory notNil! !

!AbstractEvent methodsFor: 'testing' stamp: 'rw 7/1/2003 19:53'!
isRecategorized

	^false! !

!AbstractEvent methodsFor: 'testing' stamp: 'rw 6/30/2003 08:34'!
isRemoved

	^false! !

!AbstractEvent methodsFor: 'testing' stamp: 'rw 7/1/2003 11:35'!
isRenamed

	^false! !

!AbstractEvent methodsFor: 'testing' stamp: 'NS 1/27/2004 12:44'!
isReorganized
	^ false! !


!AbstractEvent methodsFor: 'triggering' stamp: 'rw 7/14/2003 17:06'!
trigger: anEventManager 
	"Trigger the event manager."

	anEventManager triggerEvent: self eventSelector with: self.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AbstractEvent class
	instanceVariableNames: ''!

!AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/19/2004 18:42'!
class: aClass
	^ self item: aClass kind: AbstractEvent classKind.! !

!AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/19/2004 18:42'!
class: aClass category: cat 
	| instance |
	instance := self class: aClass.
	instance itemCategory: cat.
	^instance! !

!AbstractEvent class methodsFor: 'instance creation' stamp: 'rw 7/9/2003 11:19'!
item: anItem kind: anItemKind

	^self basicNew item: anItem kind: anItemKind! !

!AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/16/2004 14:19'!
method: aMethod class: aClass

	| instance |
	instance := self item: aMethod kind: self methodKind.
	instance itemClass: aClass.
	^instance! !

!AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/16/2004 14:20'!
method: aMethod protocol: prot class: aClass

	| instance |
	instance := self method: aMethod class: aClass.
	instance itemProtocol: prot.
	^instance! !

!AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 10:48'!
method: aMethod selector: aSymbol class: aClass

	| instance |
	instance := self item: aMethod kind: self methodKind.
	instance itemSelector: aSymbol.
	instance itemClass: aClass.
	^instance! !

!AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 10:49'!
method: aMethod selector: aSymbol class: aClass requestor: requestor

	| instance |
	instance := self method: aMethod selector: aSymbol class: aClass.
	instance itemRequestor: requestor.
	^instance! !

!AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 10:49'!
method: aMethod selector: aSymbol protocol: prot class: aClass

	| instance |
	instance := self method: aMethod selector: aSymbol class: aClass.
	instance itemProtocol: prot.
	^instance! !

!AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 10:50'!
method: aMethod selector: aSymbol protocol: prot class: aClass requestor: requestor

	| instance |
	instance := self method: aMethod selector: aSymbol protocol: prot class: aClass.
	instance itemRequestor: requestor.
	^instance! !

!AbstractEvent class methodsFor: 'instance creation' stamp: 'rw 6/30/2003 09:20'!
new
	"Override new to trigger an error, since we want to use specialized methods to create basic and higher-level events."

	^self error: 'Instances can only be created using specialized instance creation methods.'! !


!AbstractEvent class methodsFor: 'accessing' stamp: 'NS 1/16/2004 14:08'!
allChangeKinds
	"AbstractEvent allChangeKinds"

	^AbstractEvent allSubclasses collect: [:cl | cl changeKind]! !

!AbstractEvent class methodsFor: 'accessing' stamp: 'bvs 7/20/2004 12:12'!
allItemKinds
	"self allItemKinds"

	^(AbstractEvent class organization listAtCategoryNamed: #'item kinds') 
		collect: [:sel | self perform: sel]! !

!AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:08'!
changeKind
	"Return a symbol, with a : as last character, identifying the change kind."

	self subclassResponsibility! !

!AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:18'!
eventSelectorBlock

	^[:itemKind :changeKind | itemKind, changeKind, 'Event:']! !

!AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:19'!
itemChangeCombinations

	^self supportedKinds collect: [:itemKind | self eventSelectorBlock value: itemKind value: self changeKind]! !

!AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:04'!
supportedKinds
	"All the kinds of items that this event can take. By default this is all the kinds in the system. But subclasses can override this to limit the choices. For example, the SuperChangedEvent only works with classes, and not with methods, instance variables, ..."

	^self allItemKinds! !

!AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 11:39'!
systemEvents
	"Return all the possible events in the system. Make a cross product of 
	the items and the change types."
	"self systemEvents"

	^self allSubclasses
		inject: OrderedCollection new
		into: [:allEvents :eventClass | allEvents addAll: eventClass itemChangeCombinations; yourself]! !


!AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/9/2003 11:12'!
categoryKind

	^#category! !

!AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/9/2003 11:12'!
classKind

	^#class! !

!AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/14/2003 11:41'!
expressionKind

	^#expression! !

!AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/9/2003 11:12'!
methodKind

	^#method! !

!AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/10/2003 12:36'!
protocolKind

	^#protocol! !


!AbstractEvent class methodsFor: 'temporary' stamp: 'rw 7/11/2003 10:23'!
comment1

"Smalltalk organization removeElement: #ClassForTestingSystemChanges3
Smalltalk garbageCollect 
Smalltalk organizati

classify:under:


SystemChangeNotifier uniqueInstance releaseAll
SystemChangeNotifier uniqueInstance noMoreNotificationsFor: aDependent.


aDependent := SystemChangeNotifierTest new.
SystemChangeNotifier uniqueInstance
	notifyOfAllSystemChanges: aDependent
	using: #event:

SystemChangeNotifier uniqueInstance classAdded: #Foo inCategory: #FooCat



| eventSource dependentObject |
eventSource := EventManager new.
dependentObject := Object new.

register - dependentObject becomes dependent:
eventSource
	when: #anEvent send: #error to: dependentObject.

unregister dependentObject:
eventSource removeDependent: dependentObject.

[eventSource triggerEvent: #anEvent]
	on: Error
	do: [:exc | self halt: 'Should not be!!']."! !

!AbstractEvent class methodsFor: 'temporary' stamp: 'rw 7/11/2003 10:24'!
comment2

"HTTPSocket useProxyServerNamed: 'proxy.telenet.be' port: 8080
TestRunner open

--------------------
We propose two orthogonal groups to categorize each event:
(1) the 'change type':
	added, removed, modified, renamed
	+ the composite 'changed' (see below for an explanation)
(2) the 'item type':
	class, method, instance variable, pool variable, protocol, category
	+ the composite 'any' (see below for an explanation).
The list of supported events is the cross product of these two lists (see below for an explicit enumeration of the events).

Depending on the change type, certain information related to the change is always present (for adding, the new things that was added, for removals, what was removed, for renaming, the old and the new name, etc.).

Depending on the item type, information regarding the item is present (for a method, which class it belongs to). 

Certain events 'overlap', for example, a method rename triggers a class change. To capture this I impose a hierarchy on the 'item types' (just put some numbers to clearly show the idea. They don't need numbers, really. Items at a certain categories are included by items one category number higher):
level 1 category
level 2 class
level 3 instance variable, pool variable, protocol, method.

Changes propagate according to this tree: any 'added', 'removed' or 'renamed' change type in level X triggers a 'changed' change type in level X - 1. A 'modified' change type does not trigger anything special.
For example, a method additions triggers a class modification. This does not trigger a category modification.

Note that we added 'composite events': wildcards for the 'change type' ('any' - any system additions) and for the 'item type' ('Changed' - all changes related to classes), and one for 'any change systemwide' (systemChanged).

This result is this list of Events:

classAdded
classRemoved
classModified
classRenamed (?)
classChanged (composite)

methodAdded
methodRemoved
methodModified
methodRenamed (?)
methodChanged (composite)

instanceVariableAdded
instanceVariableRemoved
instanceVariableModified 
instanceVariableRenamed (?)
instanceVariableChanged (composite)

protocolAdded
protocolRemoved
protocolModified
protocolRenamed (?)
protocolChanged (composite)

poolVariableAdded
poolVariableRemoved
poolVariableModified
poolVariableRenamed (?)
poolChanged (composite)

categoryAdded
categoryRemoved
categoryModified
categeryRenamed (?)
categoryChanged (composite)

anyAdded (composite)
anyRemoved (composite)
anyModified (composite)
anyRenamed (composite)

anyChanged (composite)



To check: can we pass somehow the 'source' of the change (a browser, a file-in, something else) ? Maybe by checking the context, but should not be too expensive either... I found this useful in some of my tools, but it might be too advanced to have in general. Tools that need this can always write code to check it for them.  But is not always simple...


Utilities (for the recent methods) and ChangeSet are the two main clients at this moment.

Important: make it very explicit that the event is send synchronously (or asynchronously, would we take that route).


					category
						class
							comment
							protocol
								method
OR
				category
				Smalltalk
					class
						comment
						protocol
						method
??



						Smalltalk	category
								\	/
								class
							/	  |	\
						comment  |	protocol
								  |	/
								method

"! !

!AbstractEvent class methodsFor: 'temporary' stamp: 'rw 7/11/2003 15:43'!
comment3

"Things to consider for trapping:
ClassOrganizer>>#changeFromCategorySpecs:
	Problem: I want to trap this to send the appropriate bunch of ReCategorization events, but ClassOrganizer instances do not know where they belong to (what class, or what system); it just uses symbols. So I cannot trigger the change, because not enough information is available. This is a conceptual problem: the organization is stand-alone implementation-wise, while conceptually it belongs to a class. The clean solution could be to reroute this message to a class, but this does not work for all of the senders (that would work from the browserm but not for the file-in).

Browser>>#categorizeAllUncategorizedMethods
	Problem: should be trapped to send a ReCategorization event. However, this is model code that should not be in the Browser. Clean solution is to move it out of there to the model, and then trap it there (or reroute it to one of the trapped places).

Note: Debugger>>#contents:notifying: recompiles methods when needed, so I trapped it to get updates. However, I need to find a way to write a unit test for this. Haven't gotten around yet for doing this though...
"! !

!AbstractEvent class methodsFor: 'temporary' stamp: 'sd 3/9/2004 19:42'!
saveChangeNotificationAsSARFileWithNumber: aNumber 
	"Use the SARBuilder package to output the SystemChangeNotification 
	stuff as a SAR file. Put this statement here so that I don't forget it 
	when moving between images :-)"
	"self saveChangeNotificationAsSARFileWithNumber: 6"

	| filename changesText readmeText dumper |
	filename := 'SystemchangeNotification'.
	dumper _ self class environment at: #SARChangeSetDumper ifAbsent: [ ^self ].
	changesText := 
'
0.6 Version for Squeak 3.7 (no longer for 3.6!!!!) Changed one hook method to make this version work in Squeak3.7. Download version 5 from http://www.iam.unibe.ch/~wuyts/SystemchangeNotification5.sar if you are working with Squeak 3.6.

0.5 Updated the safeguard mechanism so that clients with halts and errors do not stop all notifications. Added and updated new tests for this. If this interests you have a look at the class WeakActionSequenceTrappingErrors.

0.4 Ported to Squeak 3.6.

0.3 Added the hooks for instance variables (addition, removal and renaming). Refactored the tests.

0.2 Added hooks and tests for method removal and method recategorization.

0.1 First release'.
	readmeText :=
'Implements (part of) the system change notification mechanism. Clients that want to receive notifications about system changes should look at the category #public of the class SystemChangeNotifier, and the unit tests.

VERY IMPORTANT: This version is for Squeak 3.7 only. It will not work in Squeak version 3.6. Download and install the last version that worked in Squeak 3.6 (version 5) from the following URL: http://www.iam.unibe.ch/~wuyts/SystemchangeNotification5.sar'.

	(dumper
		on: Project current changeSet
		including: (ChangeSorter allChangeSetNames
				select: [:ea | 'SystemChangeHooks' match: ea])) changesText: changesText;
		 readmeText: readmeText;
		 fileOutAsZipNamed: filename , aNumber printString , '.sar'! !
Object subclass: #AbstractFont
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Text'!
!AbstractFont commentStamp: '<historical>' prior: 0!
AbstractFont defines the generic interface that all fonts need to implement.!


!AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:19'!
ascent

	self subclassResponsibility.
! !

!AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:18'!
ascentOf: aCharacter

	^ self ascent.
! !

!AbstractFont methodsFor: 'accessing' stamp: 'nk 4/2/2004 11:06'!
baseKern
	^0! !

!AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:18'!
basicAscentOf: aCharacter

	^ self ascent.
! !

!AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:19'!
basicDescentOf: aCharacter

	^ self descent.
! !

!AbstractFont methodsFor: 'accessing' stamp: 'ar 5/19/2000 14:56'!
characterToGlyphMap
	"Return the character to glyph mapping table. If the table is not provided the character scanner will query the font directly for the width of each individual character."
	^nil! !

!AbstractFont methodsFor: 'accessing' stamp: 'nk 3/15/2004 18:57'!
derivativeFonts
	^#()! !

!AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:20'!
descent

	self subclassResponsibility.
! !

!AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:20'!
descentOf: aCharacter

	^ self descent.
! !

!AbstractFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:15'!
familyName
	"Answer the name to be used as a key in the TextConstants dictionary."
	^self subclassResponsibility! !

!AbstractFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:14'!
height
	"Answer the height of the receiver, total of maximum extents of 
	characters above and below the baseline."

	^self subclassResponsibility! !

!AbstractFont methodsFor: 'accessing' stamp: 'nk 5/26/2003 09:45'!
isRegular
	^false! !

!AbstractFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:14'!
lineGrid
	"Answer the relative space between lines"

	^self subclassResponsibility! !

!AbstractFont methodsFor: 'accessing' stamp: 'nk 4/2/2004 11:33'!
pixelSize
	"Make sure that we don't return a Fraction"
	^ TextStyle pointsToPixels: self pointSize! !

!AbstractFont methodsFor: 'accessing' stamp: 'nk 4/1/2004 10:48'!
pointSize
	self subclassResponsibility.! !

!AbstractFont methodsFor: 'accessing' stamp: 'nk 7/11/2004 21:15'!
textStyle
	^ TextStyle actualTextStyles detect:
		[:aStyle | aStyle fontArray includes: self] ifNone: [ TextStyle fontArray: { self } ]! !

!AbstractFont methodsFor: 'accessing' stamp: 'nk 3/22/2004 15:15'!
textStyleName
	"Answer the name to be used as a key in the TextConstants dictionary."
	^self familyName! !

!AbstractFont methodsFor: 'accessing' stamp: 'ar 5/19/2000 14:57'!
xTable
	"Return the xTable for the font. The xTable defines the left x-value for each individual glyph in the receiver. If such a table is not provided, the character scanner will ask the font directly for the appropriate width of each individual character."
	^nil! !


!AbstractFont methodsFor: 'displaying' stamp: 'ar 5/19/2000 14:59'!
displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta
	"Draw the given string from startIndex to stopIndex 
	at aPoint on the (already prepared) display context."
	^self subclassResponsibility! !

!AbstractFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 11:36'!
displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY
	"Draw the given string from startIndex to stopIndex 
	at aPoint on the (already prepared) display context."
	^self subclassResponsibility! !

!AbstractFont methodsFor: 'displaying' stamp: 'ar 5/19/2000 14:59'!
installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor
	"Install the receiver on the given DisplayContext (either BitBlt or Canvas) for further drawing operations."
	^self subclassResponsibility! !


!AbstractFont methodsFor: 'measuring' stamp: 'tak 1/11/2005 17:20'!
approxWidthOfText: aText
"Return the width of aText -- quickly, and a little bit dirty. Used by lists morphs containing Text objects to get a quick, fairly accurate measure of the width of a list item."

    | w |
    
    (aText isNil or: [aText size == 0 ])
        ifTrue:[^0].
       
    w _ self
        widthOfString: aText asString.

     "If the text has no emphasis, just return the string size.  If it is empasized, 
    just approximate the width by adding about 20% to the width"   
    (((aText runLengthFor: 1) == aText size)
        and: [(aText emphasisAt: 1) == 0 ])
            ifTrue:[^w]
            ifFalse:[ ^w * 6 // 5 ]. ! !

!AbstractFont methodsFor: 'measuring' stamp: 'sps 3/23/2004 15:50'!
widthOfStringOrText: aStringOrText
    aStringOrText ifNil:[^0].
    ^aStringOrText isText
        ifTrue:[self approxWidthOfText: aStringOrText ]
        ifFalse:[self widthOfString: aStringOrText ] ! !

!AbstractFont methodsFor: 'measuring' stamp: 'ar 12/31/2001 14:25'!
widthOfString: aString
	aString ifNil:[^0].
	^self widthOfString: aString from: 1 to: aString size.
"
	TextStyle default defaultFont widthOfString: 'zort' 21
"! !

!AbstractFont methodsFor: 'measuring' stamp: 'ar 12/31/2001 00:54'!
widthOfString: aString from: startIndex to: stopIndex
	"Measure the length of the given string between start and stop index"
	| character resultX |
	resultX _ 0.
	startIndex to: stopIndex do:[:i | 
		character _ aString at: i.
		resultX _ resultX + (self widthOf: character)].
	^resultX! !

!AbstractFont methodsFor: 'measuring' stamp: 'ar 5/19/2000 14:58'!
widthOf: aCharacter
	"Return the width of the given character"
	^self subclassResponsibility! !


!AbstractFont methodsFor: 'testing' stamp: 'yo 2/12/2007 19:34'!
isFontSet

	^ false.
! !

!AbstractFont methodsFor: 'testing' stamp: 'nk 6/25/2003 12:54'!
isTTCFont
	^false! !


!AbstractFont methodsFor: 'notifications' stamp: 'nk 4/2/2004 11:25'!
pixelsPerInchChanged
	"The definition of TextStyle class>>pixelsPerInch has changed. Do whatever is necessary."! !


!AbstractFont methodsFor: 'caching' stamp: 'nk 3/15/2004 18:47'!
releaseCachedState
	! !


!AbstractFont methodsFor: '*siss-private' stamp: 'yo 3/5/2007 11:31'!
sissIsLiteral

	^ true.
! !


!AbstractFont methodsFor: '*siss-interface' stamp: 'yo 3/5/2007 11:27'!
sissStoreString

	^ self fontNameWithPointSize, ' ', self emphasis asString! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AbstractFont class
	instanceVariableNames: ''!

!AbstractFont class methodsFor: 'as yet unclassified' stamp: 'nk 9/1/2004 11:41'!
emphasisStringFor: emphasisCode
	"Answer a translated string that represents the attributes given in emphasisCode."

	| emphases bit |
	emphasisCode = 0 ifTrue: [ ^'Normal' translated ].

	emphases := (IdentityDictionary new)
		at: 1 put: 'Bold' translated;
		at: 2 put: 'Italic' translated;
		at: 4 put: 'Underlined' translated;
		at: 8 put: 'Narrow' translated;
		at: 16 put: 'StruckOut' translated;
		yourself.

	bit := 1.
	^String streamContents: [ :s |
		[ bit < 32 ] whileTrue: [ | code |
			code := emphasisCode bitAnd: bit.
			code isZero ifFalse: [ s nextPutAll: (emphases at: code); space ].
			bit := bit bitShift: 1 ].
		s position isZero ifFalse: [ s skip: -1 ].
	]! !


!AbstractFont class methodsFor: '*siss-instance creation' stamp: 'yo 3/5/2007 11:57'!
sissCreateInstanceFromSexp: sexp idref: idref from: from to: to

	| stream space familyName size emphasisCode |
	stream := ReadStream on: (sexp attributeAt: #value).
	space := Character space.
	familyName := stream upTo: space.
	size := (stream upTo: space) asInteger.
	emphasisCode := (stream upTo: space) asInteger.
	^self familyName: familyName size: size emphasized: emphasisCode.
! !
Model subclass: #AbstractHierarchicalList
	instanceVariableNames: 'currentSelection myBrowser'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Explorer'!
!AbstractHierarchicalList commentStamp: '<historical>' prior: 0!
Contributed by Bob Arning as part of the ObjectExplorer package.
!


!AbstractHierarchicalList methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/1999 15:22'!
genericMenu: aMenu

	aMenu add: 'no menu yet' target: self selector: #yourself.
	^aMenu! !

!AbstractHierarchicalList methodsFor: 'as yet unclassified' stamp: 'RAA 4/7/1999 16:44'!
getCurrentSelection

	^currentSelection! !

!AbstractHierarchicalList methodsFor: 'as yet unclassified' stamp: 'RAA 4/7/1999 16:46'!
noteNewSelection: x

	currentSelection _ x.
	self changed: #getCurrentSelection.
	currentSelection ifNil: [^self].
	currentSelection sendSettingMessageTo: self.
! !

!AbstractHierarchicalList methodsFor: 'as yet unclassified' stamp: 'RAA 4/7/1999 16:53'!
perform: selector orSendTo: otherTarget
	"Selector was just chosen from a menu by a user.  If can respond, then
perform it on myself. If not, send it to otherTarget, presumably the
editPane from which the menu was invoked."

	(self respondsTo: selector)
		ifTrue: [^ self perform: selector]
		ifFalse: [^ otherTarget perform: selector]! !

!AbstractHierarchicalList methodsFor: 'as yet unclassified' stamp: 'RAA 4/7/1999 16:47'!
update: aSymbol

	aSymbol == #hierarchicalList ifTrue: [
		^self changed: #getList
	].
	super update: aSymbol! !
Object subclass: #AbstractLauncher
	instanceVariableNames: 'parameters'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!
!AbstractLauncher commentStamp: '<historical>' prior: 0!
The class AutoStart in combination with the Launcher classes provides a mechanism for starting Squeak from the command line or a web page. Parameters on the command line or in the embed tag in the web page a parsed and stored in the lauchner's parameter dictionary.
Subclasses can access these parameters to determine what to do.

CommandLineLauncherExample provides an example for a command line application. if you start squeak with a command line 'class Integer' it will launch a class browser on class Integer.
To enable this execute
CommandLineLauncherExample activate
before you save the image.
To disable execute
CommandLineLauncherExample deactivate

The PluginLauchner is an example how to use this framework to start Squeak as a browser plugin. It looks for a parameter 'src' which should point to a file containing a squeak script.!


!AbstractLauncher methodsFor: 'private' stamp: 'jm 8/20/1999 15:33'!
commandLine: aString
	"Start up this launcher from within Squeak as if it Squeak been launched the given command line."

	| dict tokens cmd arg |
	dict _ Dictionary new.
	tokens _ ReadStream on: (aString findTokens: ' ').
	[cmd _ tokens next.
	 arg _ tokens next.
	 ((cmd ~~ nil) and: [arg ~~ nil])]
		whileTrue: [dict at: cmd put: arg].
	self parameters: dict.
	self startUp.
! !

!AbstractLauncher methodsFor: 'private' stamp: 'mir 9/23/1999 13:18'!
determineParameterNameFrom: alternateParameterNames
	"Determine which of the given alternate parameter names is actually used."

	^alternateParameterNames detect: [:each | self includesParameter: each asUppercase] ifNone: [nil] ! !

!AbstractLauncher methodsFor: 'private' stamp: 'mir 1/11/2000 16:35'!
includesParameter: parName
	"Return if the parameter named parName exists."
	^self parameters
		includesKey: parName asUppercase! !

!AbstractLauncher methodsFor: 'private' stamp: 'mdr 4/10/2001 10:50'!
numericParameterAtOneOf: alternateParameterNames ifAbsent: aBlock
	"Return the parameter named using one of the alternate names or an empty string"

	| parameterValue |
	parameterValue _ self parameterAtOneOf: alternateParameterNames.
	parameterValue isEmpty
		ifTrue: [^aBlock value].
	^[Number readFrom: parameterValue] ifError: aBlock 

! !

!AbstractLauncher methodsFor: 'private' stamp: 'mir 8/4/1999 14:19'!
parameterAt: parName
	"Return the parameter named parName or an empty string"
	^self
		parameterAt: parName
		ifAbsent: ['']! !

!AbstractLauncher methodsFor: 'private' stamp: 'mir 1/11/2000 16:36'!
parameterAt: parName ifAbsent: aBlock
	"Return the parameter named parName.
	Evaluate the block if parameter does not exist."
	^self parameters
		at: parName asUppercase
		ifAbsent: [aBlock value]! !

!AbstractLauncher methodsFor: 'private' stamp: 'mir 9/23/1999 12:09'!
parameterAtOneOf: alternateParameterNames
	| parameterName |
	"Return the parameter named using one of the alternate names or an empty string"

	parameterName _ self determineParameterNameFrom: alternateParameterNames.
	^parameterName isNil
		ifTrue: ['']
		ifFalse: [self parameterAt: parameterName ifAbsent: ['']]! !

!AbstractLauncher methodsFor: 'private' stamp: 'mir 1/11/2000 16:53'!
parameters
	parameters == nil
		ifTrue: [parameters _ self class extractParameters].
	^parameters! !

!AbstractLauncher methodsFor: 'private' stamp: 'mir 7/29/1999 10:21'!
parameters: startupParameters
	parameters _ startupParameters! !


!AbstractLauncher methodsFor: 'running' stamp: 'tk 10/24/2001 06:40'!
startUp
	"A backstop for subclasses.  Note that this is not a class message (most startUps are class messages)."

! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AbstractLauncher class
	instanceVariableNames: ''!

!AbstractLauncher class methodsFor: 'private' stamp: 'mir 8/4/1999 13:57'!
autoStarter
	^AutoStart! !

!AbstractLauncher class methodsFor: 'private' stamp: 'sd 9/30/2003 13:55'!
extractParameters
	
	^ SmalltalkImage current extractParameters! !


!AbstractLauncher class methodsFor: 'activation' stamp: 'mir 8/6/1999 18:14'!
activate
	"Register this launcher with the auto start class"

	self autoStarter addLauncher: self! !

!AbstractLauncher class methodsFor: 'activation'!
deactivate
	"Unregister this launcher with the auto start class"
	self autoStarter removeLauncher: self! !
RectangleMorph subclass: #AbstractMediaEventMorph
	instanceVariableNames: 'startTimeInScore endTimeInScore'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!
!AbstractMediaEventMorph commentStamp: '<historical>' prior: 0!
An abstract representation of media events to be placed in a PianoRollScoreMorph (or others as they are developed)!


!AbstractMediaEventMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/7/2000 12:58'!
endTime

	^endTimeInScore ifNil: [startTimeInScore + 100]! !


!AbstractMediaEventMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 1! !

!AbstractMediaEventMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color paleYellow! !

!AbstractMediaEventMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:38'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self layoutPolicy: TableLayout new;
	  listDirection: #leftToRight;
	  wrapCentering: #topLeft;
	  hResizing: #shrinkWrap;
	  vResizing: #shrinkWrap;
	  layoutInset: 2;
	  rubberBandCells: true! !


!AbstractMediaEventMorph methodsFor: '*sound-piano rolls' stamp: 'RAA 12/9/2000 18:45'!
justDroppedIntoPianoRoll: pianoRoll event: evt
	
	| ambientEvent |
	startTimeInScore _ pianoRoll timeForX: self left.

	ambientEvent _ AmbientEvent new 
		morph: self;
		time: startTimeInScore.

	pianoRoll score addAmbientEvent: ambientEvent.

	"self endTime > pianoRoll scorePlayer durationInTicks ifTrue:
		[pianoRoll scorePlayer updateDuration]"
! !
Object subclass: #AbstractScoreEvent
	instanceVariableNames: 'time'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!
!AbstractScoreEvent commentStamp: '<historical>' prior: 0!
Abstract class for timed events in a MIDI score.
!


!AbstractScoreEvent methodsFor: 'accessing' stamp: 'di 6/17/1999 14:28'!
adjustTimeBy: delta

	time _ time + delta
! !

!AbstractScoreEvent methodsFor: 'accessing' stamp: 'jm 8/27/1998 16:38'!
endTime
	"Subclasses should override to return the ending time if the event has some duration."

	^ time
! !

!AbstractScoreEvent methodsFor: 'accessing' stamp: 'jm 12/31/97 11:43'!
time

	^ time
! !

!AbstractScoreEvent methodsFor: 'accessing' stamp: 'jm 12/31/97 11:43'!
time: aNumber

	time _ aNumber.
! !


!AbstractScoreEvent methodsFor: 'classification' stamp: 'jm 9/10/1998 09:43'!
isControlChange

	^ false
! !

!AbstractScoreEvent methodsFor: 'classification' stamp: 'jm 12/31/97 11:46'!
isNoteEvent

	^ false
! !

!AbstractScoreEvent methodsFor: 'classification' stamp: 'jm 9/10/1998 09:43'!
isPitchBend

	^ false
! !

!AbstractScoreEvent methodsFor: 'classification' stamp: 'jm 9/10/1998 09:43'!
isProgramChange

	^ false
! !

!AbstractScoreEvent methodsFor: 'classification' stamp: 'jm 12/31/97 11:46'!
isTempoEvent

	^ false
! !


!AbstractScoreEvent methodsFor: 'midi' stamp: 'jm 9/10/1998 18:31'!
outputOnMidiPort: aMidiPort
	"Output this event to the given MIDI port. This default implementation does nothing."
! !
Object subclass: #AbstractSound
	instanceVariableNames: 'envelopes mSecsSinceStart samplesUntilNextControl scaledVol scaledVolIncr scaledVolLimit'
	classVariableNames: 'FloatScaleFactor MaxScaledValue PitchesForBottomOctave ScaleFactor Sounds TopOfBottomOctave UnloadedSnd'
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!AbstractSound methodsFor: 'initialization' stamp: 'jm 12/9/97 11:31'!
duration: seconds
	"Scale my envelopes to the given duration. Subclasses overriding this method should include a resend to super."

	envelopes do: [:e | e duration: seconds].
! !

!AbstractSound methodsFor: 'initialization' stamp: 'jm 2/4/98 09:54'!
initialize

	envelopes _ #().
	mSecsSinceStart _ 0.
	samplesUntilNextControl _ 0.
	scaledVol _ (1.0 * ScaleFactor) rounded.
	scaledVolIncr _ 0.
	scaledVolLimit _ scaledVol.
! !

!AbstractSound methodsFor: 'initialization' stamp: 'jm 3/24/1999 12:03'!
loudness: aNumber
	"Initialize my volume envelopes and initial volume. Subclasses overriding this method should include a resend to super."

	| vol |
	vol _ (aNumber asFloat max: 0.0) min: 1.0.
	envelopes do: [:e |
		(e isKindOf: VolumeEnvelope) ifTrue: [e scale: vol]].
	self initialVolume: vol.
! !

!AbstractSound methodsFor: 'initialization' stamp: 'jm 7/6/1998 17:04'!
nameOrNumberToPitch: aStringOrNumber
	"Answer the pitch in cycles/second for the given pitch specification. The specification can be either a numeric pitch or pitch name such as 'c4'."

	aStringOrNumber isNumber
		ifTrue: [^ aStringOrNumber asFloat]
		ifFalse: [^ AbstractSound pitchForName: aStringOrNumber]
! !

!AbstractSound methodsFor: 'initialization' stamp: 'jm 8/19/1998 08:45'!
setPitch: pitchNameOrNumber dur: d loudness: l
	"Initialize my envelopes for the given parameters. Subclasses overriding this method should include a resend to super."

	| p |
	p _ self nameOrNumberToPitch: pitchNameOrNumber.
	envelopes do: [:e |
		e volume: l.
		e centerPitch: p].
	self initialVolume: l.
	self duration: d.
! !

!AbstractSound methodsFor: 'initialization' stamp: 'jm 8/3/1998 17:11'!
soundForMidiKey: midiKey dur: d loudness: l
	"Answer an initialized sound object (a copy of the receiver) that generates a note for the given MIDI key (in the range 0..127), duration (in seconds), and loudness (in the range 0.0 to 1.0)."

	^ self copy
		setPitch: (AbstractSound pitchForMIDIKey: midiKey)
		dur: d
		loudness: l
! !

!AbstractSound methodsFor: 'initialization' stamp: 'jm 8/3/1998 16:58'!
soundForPitch: pitchNameOrNumber dur: d loudness: l
	"Answer an initialized sound object (a copy of the receiver) that generates a note of the given pitch, duration, and loudness. Pitch may be a numeric pitch or a string pitch name such as 'c4'. Duration is in seconds and loudness is in the range 0.0 to 1.0."

	^ self copy setPitch: pitchNameOrNumber dur: d loudness: l
! !


!AbstractSound methodsFor: 'accessing' stamp: 'sw 12/20/2006 04:17'!
durationInMilliseconds
	"Answer the duration in milliseconds."

	^ self duration * 1000! !

!AbstractSound methodsFor: 'accessing' stamp: 'tak 4/23/2007 20:43'!
isCompressed
	^ false! !

!AbstractSound methodsFor: 'accessing' stamp: 'jm 12/16/2001 22:34'!
isStereo
	"Answer true if this sound has distinct left and right channels. (Every sound plays into a stereo sample buffer, but most sounds, which produce exactly the same samples on both channels, are not stereo.)"

	^ false
! !


!AbstractSound methodsFor: 'sampling rates' stamp: 'jm 12/15/97 14:15'!
controlRate
	"Answer the number of control changes per second."

	^ 100
! !

!AbstractSound methodsFor: 'sampling rates' stamp: 'jm 12/16/2001 13:14'!
originalSamplingRate
	"For sampled sounds, answer the sampling rate used to record the stored samples. For other sounds, this is the same as the playback sampling rate."

	^ SoundPlayer samplingRate
! !

!AbstractSound methodsFor: 'sampling rates' stamp: 'jm 12/17/97 18:00'!
samplingRate
	"Answer the sampling rate in samples per second."

	^ SoundPlayer samplingRate
! !


!AbstractSound methodsFor: 'copying' stamp: 'jm 12/15/97 19:15'!
copy
	"A sound should copy all of the state needed to play itself, allowing two copies of a sound to play at the same time. These semantics require a recursive copy but only down to the level of immutable data. For example, a SampledSound need not copy its sample buffer. Subclasses overriding this method should include a resend to super."

	^ self clone copyEnvelopes
! !

!AbstractSound methodsFor: 'copying' stamp: 'jm 12/17/97 22:22'!
copyEnvelopes
	"Private!! Support for copying. Copy my envelopes."

	envelopes _ envelopes collect: [:e | e copy target: self].
! !

!AbstractSound methodsFor: 'copying' stamp: 'di 3/4/1999 21:29'!
sounds
	"Allows simple sounds to behave as, eg, sequential sounds"

	^ Array with: self! !


!AbstractSound methodsFor: 'conversion' stamp: 'jm 12/16/2001 13:26'!
asSampledSound
	"Answer a SampledSound containing my samples. If the receiver is some kind of sampled sound, the resulting SampledSound will have the same original sampling rate as the receiver."

	^ SampledSound samples: self samples samplingRate: self originalSamplingRate
! !


!AbstractSound methodsFor: 'envelopes' stamp: 'jm 12/17/97 22:23'!
addEnvelope: anEnvelope
	"Add the given envelope to my envelopes list."

	anEnvelope target: self.
	envelopes _ envelopes copyWith: anEnvelope.
! !

!AbstractSound methodsFor: 'envelopes' stamp: 'jm 12/15/97 17:02'!
envelopes
	"Return my collection of envelopes."

	^ envelopes
! !

!AbstractSound methodsFor: 'envelopes' stamp: 'jm 8/18/1998 09:57'!
removeAllEnvelopes
	"Remove all envelopes from my envelopes list."

	envelopes _ #().
! !

!AbstractSound methodsFor: 'envelopes' stamp: 'jm 12/15/97 17:02'!
removeEnvelope: anEnvelope
	"Remove the given envelope from my envelopes list."

	envelopes _ envelopes copyWithout: anEnvelope.
! !


!AbstractSound methodsFor: 'volume' stamp: 'RAA 8/11/2000 11:51'!
adjustVolumeTo: vol overMSecs: mSecs
	"Adjust the volume of this sound to the given volume, a number in the range [0.0..1.0], over the given number of milliseconds. The volume will be changed a little bit on each sample until the desired volume is reached."

	| newScaledVol |

	self flag: #bob.		"I removed the upper limit to allow making sounds louder. hmm..."

	newScaledVol _ (32768.0 * vol) truncated.
	newScaledVol = scaledVol ifTrue: [^ self].
	scaledVolLimit _ newScaledVol.
	"scaledVolLimit > ScaleFactor ifTrue: [scaledVolLimit _ ScaleFactor]."
	scaledVolLimit < 0 ifTrue: [scaledVolLimit _ 0].
	mSecs = 0
		ifTrue: [  "change immediately"
			scaledVol _ scaledVolLimit.
			scaledVolIncr _ 0]
		ifFalse: [
			scaledVolIncr _
				((scaledVolLimit - scaledVol) * 1000) // (self samplingRate * mSecs)].
! !

!AbstractSound methodsFor: 'volume' stamp: 'jm 12/17/97 17:39'!
initialVolume: vol
	"Set the initial volume of this sound to the given volume, a number in the range [0.0..1.0]."

	scaledVol _ (((vol asFloat min: 1.0) max: 0.0) * ScaleFactor) rounded.
	scaledVolLimit _ scaledVol.
	scaledVolIncr _ 0.
! !

!AbstractSound methodsFor: 'volume' stamp: 'jm 8/13/1998 16:37'!
loudness
	"Answer the current volume setting for this sound."

	^ scaledVol asFloat / ScaleFactor asFloat! !

!AbstractSound methodsFor: 'volume' stamp: 'jm 8/13/1998 16:28'!
volumeEnvelopeScaledTo: scalePoint
	"Return a collection of values representing my volume envelope scaled by the given point. The scale point's x component is pixels/second and its y component is the number of pixels for full volume."

	self error: 'not yet implemented'.
! !


!AbstractSound methodsFor: 'playing' stamp: 'jm 1/26/98 22:05'!
computeSamplesForSeconds: seconds
	"Compute the samples of this sound without outputting them, and return the resulting buffer of samples."

	| buf |
	self reset.
	buf _ SoundBuffer newStereoSampleCount: (self samplingRate * seconds) asInteger.
	self playSampleCount: buf stereoSampleCount into: buf startingAt: 1.
	^ buf
! !

!AbstractSound methodsFor: 'playing' stamp: 'ar 12/5/1998 22:20'!
isPlaying
	"Return true if the receiver is currently playing"
	^ SoundPlayer isPlaying: self! !

!AbstractSound methodsFor: 'playing' stamp: 'di 5/30/1999 12:46'!
millisecondsSinceStart

	^ mSecsSinceStart! !

!AbstractSound methodsFor: 'playing' stamp: 'jm 8/24/97 20:48'!
pause
	"Pause this sound. It can be resumed from this point, or reset and resumed to start from the beginning."

	SoundPlayer pauseSound: self.! !

!AbstractSound methodsFor: 'playing' stamp: 'gk 2/24/2004 22:23'!
play
	"Play this sound to the sound output port in real time."

	SoundPlayer playSound: self.! !

!AbstractSound methodsFor: 'playing' stamp: 'jm 8/13/1998 15:09'!
playAndWaitUntilDone
	"Play this sound to the sound ouput port and wait until it has finished playing before returning."

	SoundPlayer playSound: self.
	[self samplesRemaining > 0] whileTrue.
	(Delay forMilliseconds: 2 * SoundPlayer bufferMSecs) wait.  "ensure last buffer has been output"
! !

!AbstractSound methodsFor: 'playing' stamp: 'jm 8/18/1998 10:52'!
playChromaticRunFrom: startPitch to: endPitch
	"Play a fast chromatic run between the given pitches. Useful for auditioning a sound."

	(AbstractSound chromaticRunFrom: startPitch to: endPitch on: self) play.
! !

!AbstractSound methodsFor: 'playing' stamp: 'jm 8/13/1998 16:17'!
playSampleCount: n into: aSoundBuffer startingAt: startIndex
	"Mix the next n samples of this sound into the given buffer starting at the given index. Update the receiver's control parameters periodically."

	| fullVol samplesBetweenControlUpdates pastEnd i remainingSamples count |
	fullVol _ AbstractSound scaleFactor.
	samplesBetweenControlUpdates _ self samplingRate // self controlRate.
	pastEnd _ startIndex + n.  "index just after the last sample"
	i _ startIndex.
	[i < pastEnd] whileTrue: [
		remainingSamples _ self samplesRemaining.
		remainingSamples <= 0 ifTrue: [^ self].
		count _ pastEnd - i.
		samplesUntilNextControl < count ifTrue: [count _ samplesUntilNextControl].
		remainingSamples < count ifTrue: [count _ remainingSamples].
		self mixSampleCount: count into: aSoundBuffer startingAt: i leftVol: fullVol rightVol: fullVol.
		samplesUntilNextControl _ samplesUntilNextControl - count.
		samplesUntilNextControl <= 0 ifTrue: [
			self doControl.
			samplesUntilNextControl _ samplesBetweenControlUpdates].
		i _ i + count].
! !

!AbstractSound methodsFor: 'playing' stamp: 'jm 7/5/1998 17:53'!
playSilently
	"Compute the samples of this sound without outputting them. Used for performance analysis."

	| bufSize buf |
	self reset.
	bufSize _ self samplingRate // 10.
	buf _ SoundBuffer newStereoSampleCount: bufSize.
	[self samplesRemaining > 0] whileTrue: [
		buf primFill: 0.
		self playSampleCount: bufSize into: buf startingAt: 1].
! !

!AbstractSound methodsFor: 'playing' stamp: 'jm 1/26/98 22:06'!
playSilentlyUntil: startTime
	"Compute the samples of this sound without outputting them. Used to fast foward to a particular starting time. The start time is given in seconds."

	| buf startSample nextSample samplesRemaining n |
	self reset.
	buf _ SoundBuffer newStereoSampleCount: (self samplingRate // 10).
	startSample _ (startTime * self samplingRate) asInteger.
	nextSample _ 1.
	[self samplesRemaining > 0] whileTrue: [
		nextSample >= startSample ifTrue: [^ self].
		samplesRemaining _ startSample - nextSample.
		samplesRemaining > buf stereoSampleCount
			ifTrue: [n _ buf stereoSampleCount]
			ifFalse: [n _ samplesRemaining].
		self playSampleCount: n into: buf startingAt: 1.
		nextSample _ nextSample + n].
! !

!AbstractSound methodsFor: 'playing' stamp: 'jm 3/4/98 13:16'!
resumePlaying
	"Resume playing this sound from where it last stopped."

	SoundPlayer resumePlaying: self.
! !

!AbstractSound methodsFor: 'playing' stamp: 'jm 12/16/2001 13:22'!
samples
	"Answer a monophonic sample buffer containing my samples. The left and write channels are merged."
	"Warning: This may require a lot of memory!!"

	^ (self computeSamplesForSeconds: self duration) mergeStereo
! !

!AbstractSound methodsFor: 'playing' stamp: 'jm 12/16/2001 13:24'!
viewSamples
	"Open a WaveEditor on my samples."

	WaveEditor openOn: self samples.
! !


!AbstractSound methodsFor: 'sound generation' stamp: 'jm 8/17/1998 13:34'!
doControl
	"Update the control parameters of this sound using its envelopes, if any."
	"Note: This is only called at a small fraction of the sampling rate."

	| pitchModOrRatioChange |
	envelopes size > 0 ifTrue: [
		pitchModOrRatioChange _ false.
		1 to: envelopes size do: [:i |
			((envelopes at: i) updateTargetAt: mSecsSinceStart)
				ifTrue: [pitchModOrRatioChange _ true]].
		pitchModOrRatioChange ifTrue: [self internalizeModulationAndRatio]].
	mSecsSinceStart _ mSecsSinceStart + (1000 // self controlRate).
! !

!AbstractSound methodsFor: 'sound generation' stamp: 'jm 2/4/98 08:56'!
internalizeModulationAndRatio
	"Overridden by FMSound. This default implementation does nothing."
! !

!AbstractSound methodsFor: 'sound generation' stamp: 'jm 7/6/1998 06:40'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
	"Mix the given number of samples with the samples already in the given buffer starting at the given index. Assume that the buffer size is at least (index + count) - 1. The leftVol and rightVol parameters determine the volume of the sound in each channel, where 0 is silence and ScaleFactor is full volume."

	self subclassResponsibility.
! !

!AbstractSound methodsFor: 'sound generation' stamp: 'jm 8/17/1998 13:45'!
reset
	"Reset my internal state for a replay. Methods that override this method should do super reset."

	mSecsSinceStart _ 0.
	samplesUntilNextControl _ 0.
	envelopes size > 0 ifTrue: [
		1 to: envelopes size do: [:i | (envelopes at: i) reset]].
! !

!AbstractSound methodsFor: 'sound generation' stamp: 'jm 12/17/97 17:57'!
samplesRemaining
	"Answer the number of samples remaining until the end of this sound. A sound with an indefinite ending time should answer some large integer such as 1000000."

	^ 1000000
! !

!AbstractSound methodsFor: 'sound generation' stamp: 'jm 9/9/1998 21:56'!
stopAfterMSecs: mSecs
	"Terminate this sound this note after the given number of milliseconds. This default implementation does nothing."
! !

!AbstractSound methodsFor: 'sound generation' stamp: 'jm 9/9/1998 21:54'!
stopGracefully
	"End this note with a graceful decay. If the note has envelopes, determine the decay time from its envelopes."

	| decayInMs env |
	envelopes isEmpty
		ifTrue: [
			self adjustVolumeTo: 0 overMSecs: 10.
			decayInMs _ 10]
		ifFalse: [
			env _ envelopes first.
			decayInMs _ env attackTime + env decayTime].
	self duration: (mSecsSinceStart + decayInMs) / 1000.0.
	self stopAfterMSecs: decayInMs.
! !

!AbstractSound methodsFor: 'sound generation' stamp: 'jm 1/5/98 14:21'!
storeSample: sample in: aSoundBuffer at: sliceIndex leftVol: leftVol rightVol: rightVol
	"This method is provided for documentation. To gain 10% more speed when running sound generation in Smalltalk, this method is hand-inlined into all sound generation methods that use it."

	| i s |
		leftVol > 0 ifTrue: [
			i _ (2 * sliceIndex) - 1.
			s _ (aSoundBuffer at: i) + ((sample * leftVol) // ScaleFactor).
			s >  32767 ifTrue: [s _  32767].  "clipping!!"
			s < -32767 ifTrue: [s _ -32767].  "clipping!!"
			aSoundBuffer at: i put: s].
		rightVol > 0 ifTrue: [
			i _ 2 * sliceIndex.
			s _ (aSoundBuffer at: i) + ((sample * rightVol) // ScaleFactor).
			s >  32767 ifTrue: [s _  32767].  "clipping!!"
			s < -32767 ifTrue: [s _ -32767].  "clipping!!"
			aSoundBuffer at: i put: s].
! !

!AbstractSound methodsFor: 'sound generation' stamp: 'jm 12/17/97 17:57'!
updateVolume
	"Increment the volume envelope of this sound. To avoid clicks, the volume envelope must be interpolated at the sampling rate, rather than just at the control rate like other envelopes. At the control rate, the volume envelope computes the slope and next target volume volume for the current segment of the envelope (i.e., it sets the rate of change for the volume parameter). When that target volume is reached, incrementing is stopped until a new increment is set."
	"This method is provided for documentation. To gain 10% more speed when running sound generation in Smalltalk, it is hand-inlined into all sound generation methods that use it."

		scaledVolIncr ~= 0 ifTrue: [
			scaledVol _ scaledVol + scaledVolIncr.
			((scaledVolIncr > 0 and: [scaledVol >= scaledVolLimit]) or:
			 [scaledVolIncr < 0 and: [scaledVol <= scaledVolLimit]])
				ifTrue: [  "reached the limit; stop incrementing"
					scaledVol _ scaledVolLimit.
					scaledVolIncr _ 0]].
! !


!AbstractSound methodsFor: 'composition'!
+ aSound
	"Return the mix of the receiver and the argument sound."

	^ MixedSound new
		add: self;
		add: aSound
! !

!AbstractSound methodsFor: 'composition'!
, aSound
	"Return the concatenation of the receiver and the argument sound."

	^ SequentialSound new
		add: self;
		add: aSound
! !

!AbstractSound methodsFor: 'composition' stamp: 'jm 2/2/1999 15:53'!
asSound

	^ self
! !

!AbstractSound methodsFor: 'composition' stamp: 'jm 12/17/97 18:00'!
delayedBy: seconds
	"Return a composite sound consisting of a rest for the given amount of time followed by the receiver."

	^ (RestSound dur: seconds), self
! !


!AbstractSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 21:51'!
storeAIFFOnFileNamed: fileName
	"Store this sound as a AIFF file of the given name."

	| f |
	f _ (FileStream fileNamed: fileName) binary.
	self storeAIFFSamplesOn: f.
	f close.
! !

!AbstractSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 22:31'!
storeAIFFSamplesOn: aBinaryStream
	"Store this sound as a 16-bit AIFF file at the current SoundPlayer sampling rate. Store both channels if self isStereo is true; otherwise, store the left channel only as a mono sound."

	| samplesToStore channelCount dataByteCount |
	samplesToStore _ (self duration * self samplingRate) ceiling.
	channelCount _ self isStereo ifTrue: [2] ifFalse: [1].
	dataByteCount _ samplesToStore * channelCount * 2.

	"write AIFF file header:"
	aBinaryStream nextPutAll: 'FORM' asByteArray.
	aBinaryStream nextInt32Put: ((7 * 4) + 18) + dataByteCount.
	aBinaryStream nextPutAll: 'AIFF' asByteArray.
	aBinaryStream nextPutAll: 'COMM' asByteArray.
	aBinaryStream nextInt32Put: 18.
	aBinaryStream nextNumber: 2 put: channelCount.
	aBinaryStream nextInt32Put: samplesToStore.
	aBinaryStream nextNumber: 2 put: 16.  "bits/sample"
	self storeExtendedFloat: self samplingRate on: aBinaryStream.
	aBinaryStream nextPutAll: 'SSND' asByteArray.
	aBinaryStream nextInt32Put: dataByteCount + 8.
	aBinaryStream nextInt32Put: 0.
	aBinaryStream nextInt32Put: 0.

	"write data:"
	self storeSampleCount: samplesToStore bigEndian: true on: aBinaryStream.
! !

!AbstractSound methodsFor: 'file i/o' stamp: 'jm 3/13/1999 11:34'!
storeExtendedFloat: aNumber on: aBinaryStream
	"Store an Apple extended-precision 80-bit floating point number on the given stream."
	"Details: I could not find the specification for this format, so constants were determined empirically based on assumption of 1-bit sign, 15-bit exponent, 64-bit mantissa. This format does not seem to have an implicit one before the mantissa as some float formats do."

	| n isNeg exp mantissa |
	n _ aNumber asFloat.
	isNeg _ false.
	n < 0.0 ifTrue: [
		n _ 0.0 - n.
		isNeg _ true].
	exp _ (n log: 2.0) ceiling.
	mantissa _ (n * (2 raisedTo: 64 - exp)) truncated.
	exp _ exp + 16r4000 - 2.  "not sure why the -2 is needed..."
	isNeg ifTrue: [exp _ exp bitOr: 16r8000].  "set sign bit"
	aBinaryStream nextPut: ((exp bitShift: -8) bitAnd: 16rFF).
	aBinaryStream nextPut: (exp bitAnd: 16rFF).
	8 to: 1 by: -1 do: [:i | aBinaryStream nextPut: (mantissa digitAt: i)].
! !

!AbstractSound methodsFor: 'file i/o' stamp: 'sd 9/30/2003 13:41'!
storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream
	"Store my samples on the given stream at the current SoundPlayer sampling rate. If bigFlag is true, then each 16-bit sample is stored most-significant byte first (AIFF files), otherwise it is stored least-significant byte first (WAV files). If self isStereo is true, both channels are stored, creating a stereo file. Otherwise, only the left channel is stored, creating a mono file."

	| bufSize stereoBuffer reverseBytes remaining out |
	self reset.
	bufSize _ (2 * self samplingRate rounded) min: samplesToStore.  "two second buffer"
	stereoBuffer _ SoundBuffer newStereoSampleCount: bufSize.
	reverseBytes _ bigEndianFlag ~= (SmalltalkImage current isBigEndian).

	'Storing audio...' displayProgressAt: Sensor cursorPoint
		from: 0 to: samplesToStore during: [:bar |
			remaining _ samplesToStore.
			[remaining > 0] whileTrue: [
				bar value: samplesToStore - remaining.
				stereoBuffer primFill: 0.  "clear the buffer"
				self playSampleCount: (bufSize min: remaining) into: stereoBuffer startingAt: 1.
				self isStereo
					ifTrue: [out _ stereoBuffer]
					ifFalse: [out _ stereoBuffer extractLeftChannel].
				reverseBytes ifTrue: [out reverseEndianness].
				(aBinaryStream isKindOf: StandardFileStream)
					ifTrue: [  "optimization for files: write sound buffer directly to file"
						aBinaryStream next: (out size // 2) putAll: out startingAt: 1]  "size in words"
					ifFalse: [  "for non-file streams:"
						1 to: out monoSampleCount do: [:i | aBinaryStream int16: (out at: i)]].
				remaining _ remaining - bufSize]].
! !

!AbstractSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 21:47'!
storeSunAudioOnFileNamed: fileName
	"Store this sound as an uncompressed Sun audio file of the given name."

	| f |
	f _ (FileStream fileNamed: fileName) binary.
	self storeSunAudioSamplesOn: f.
	f close.
! !

!AbstractSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 22:32'!
storeSunAudioSamplesOn: aBinaryStream
	"Store this sound as a 16-bit Sun audio file at the current SoundPlayer sampling rate. Store both channels if self isStereo is true; otherwise, store the left channel only as a mono sound."


	| samplesToStore channelCount dataByteCount |
	samplesToStore _ (self duration * self samplingRate) ceiling.
	channelCount _ self isStereo ifTrue: [2] ifFalse: [1].
	dataByteCount _ samplesToStore * channelCount * 2.

	"write Sun audio file header"
	channelCount _ self isStereo ifTrue: [2] ifFalse: [1].
	aBinaryStream nextPutAll: '.snd' asByteArray.
	aBinaryStream uint32: 24.	"header size in bytes"
	aBinaryStream uint32: dataByteCount.
	aBinaryStream uint32: 3.	"format: 16-bit linear"
	aBinaryStream uint32: self samplingRate truncated.
	aBinaryStream uint32: channelCount.

	"write data:"
	self storeSampleCount: samplesToStore bigEndian: true on: aBinaryStream.
! !

!AbstractSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 20:03'!
storeWAVOnFileNamed: fileName
	"Store this sound as a 16-bit Windows WAV file of the given name."

	| f |
	f _ (FileStream fileNamed: fileName) binary.
	self storeWAVSamplesOn: f.
	f close.
! !

!AbstractSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 22:32'!
storeWAVSamplesOn: aBinaryStream
	"Store this sound as a 16-bit Windows WAV file at the current SoundPlayer sampling rate. Store both channels if self isStereo is true; otherwise, store the left channel only as a mono sound."

	| samplesToStore channelCount dataByteCount samplesPerSec bytesPerSec |
	samplesToStore _ (self duration * self samplingRate) ceiling.
	channelCount _ self isStereo ifTrue: [2] ifFalse: [1].
	dataByteCount _ samplesToStore * channelCount * 2.
	samplesPerSec _ self samplingRate rounded.
	bytesPerSec _ samplesPerSec * channelCount * 2.

	"file header"
	aBinaryStream
		nextPutAll: 'RIFF' asByteArray;
		nextLittleEndianNumber: 4 put: dataByteCount + 36;	"total length of all chunks"
		nextPutAll: 'WAVE' asByteArray.

	"format chunk"
	aBinaryStream
		nextPutAll: 'fmt ' asByteArray;
		nextLittleEndianNumber: 4 put: 16;	"length of this chunk"
		nextLittleEndianNumber: 2 put: 1;	"format tag"
		nextLittleEndianNumber: 2 put: channelCount;
		nextLittleEndianNumber: 4 put: samplesPerSec;
		nextLittleEndianNumber: 4 put: bytesPerSec;
		nextLittleEndianNumber: 2 put: 4;	"alignment"
		nextLittleEndianNumber: 2 put: 16.	"bits per sample"

	"data chunk"
	aBinaryStream
		nextPutAll: 'data' asByteArray;
		nextLittleEndianNumber: 4 put: dataByteCount.  "length of this chunk"

	self storeSampleCount: samplesToStore bigEndian: false on: aBinaryStream.
! !


!AbstractSound methodsFor: 'as yet unclassified' stamp: 'sw 7/24/2007 15:46'!
codecSignature
	"Backstop..."

	^ nil! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AbstractSound class
	instanceVariableNames: ''!

!AbstractSound class methodsFor: 'class initialization' stamp: 'jm 8/3/1998 16:13'!
initialize
	"AbstractSound initialize"
 
	| bottomC |
	ScaleFactor _ 2 raisedTo: 15.
	FloatScaleFactor _ ScaleFactor asFloat.
	MaxScaledValue _ ((2 raisedTo: 31) // ScaleFactor) - 1.  "magnitude of largest scaled value in 32-bits"

	"generate pitches for c-1 through c0"
	bottomC _ (440.0 / 32) * (2.0 raisedTo: -9.0 / 12.0).
	PitchesForBottomOctave _ (0 to: 12) collect: [:i | bottomC * (2.0 raisedTo: i asFloat / 12.0)].
	TopOfBottomOctave _ PitchesForBottomOctave last.
! !

!AbstractSound class methodsFor: 'class initialization' stamp: 'jm 1/5/98 13:51'!
scaleFactor

	^ ScaleFactor
! !


!AbstractSound class methodsFor: 'instance creation' stamp: 'jm 1/5/98 17:40'!
default
	"Return a default sound prototype for this class, with envelopes if appropriate. (This is in contrast to new, which returns a raw instance without envelopes.)"

	^ self new
! !

!AbstractSound class methodsFor: 'instance creation' stamp: 'jm 12/17/97 17:26'!
dur: d
	"Return a rest of the given duration."

	^ self basicNew setDur: d
! !

!AbstractSound class methodsFor: 'instance creation' stamp: 'jm 8/3/1998 17:00'!
noteSequenceOn: aSound from: anArray
	"Build a note sequence (i.e., a SequentialSound) from the given array using the given sound as the instrument. Elements are either (pitch, duration, loudness) triples or (#rest duration) pairs.  Pitches can be given as names or as numbers."
	| score pitch |
	score _ SequentialSound new.
	anArray do: [:el |
		el size = 3
			ifTrue: [
				pitch _ el at: 1.
				pitch isNumber ifFalse: [pitch _ self pitchForName: pitch].
				score add: (
					aSound
						soundForPitch: pitch
						dur: (el at: 2)
						loudness: (el at: 3) / 1000.0)]
			ifFalse: [
				score add: (RestSound dur: (el at: 2))]].
	^ score
! !

!AbstractSound class methodsFor: 'instance creation' stamp: 'jm 12/17/97 17:27'!
pitch: p dur: d loudness: l
	"Return a new sound object for a note with the given parameters."

	^ self new setPitch: p dur: d loudness: l
! !


!AbstractSound class methodsFor: 'utilities' stamp: 'DSM 9/5/2000 13:50'!
busySignal: count
	"AbstractSound busySignal: 3"
	| m s |
	s _ SequentialSound new.
	m _ MixedSound new.
	m	add: (FMSound new setPitch: 480 dur: 0.5 loudness: 0.5);
		add: (FMSound new setPitch: 620 dur: 0.5 loudness: 0.5).
	s add: m.
	s add: (FMSound new setPitch: 1 dur: 0.5 loudness: 0).
	^ (RepeatingSound repeat: s count: count) play.

! !

!AbstractSound class methodsFor: 'utilities' stamp: 'DSM 9/5/2000 13:56'!
dial: aString
	| index lo hi m s |
	"AbstractSound dial: '867-5309'" "ask for Jenny"

	s _ SequentialSound new.
	aString do: [ :c |
		c = $,
			ifTrue: [ s add: (FMSound new setPitch: 1 dur: 1 loudness: 0) ]
			ifFalse: [
				(index _ ('123A456B789C*0#D' indexOf: c)) > 0
					ifTrue: [
						lo _ #(697 770 852 941) at: (index - 1 // 4 + 1).
						hi _ #(1209 1336 1477 1633) at: (index - 1 \\ 4 + 1).
						m _ MixedSound new.
						m add: (FMSound new setPitch: lo dur: 0.15 loudness: 0.5).
						m add: (FMSound new setPitch: hi dur: 0.15 loudness: 0.5).
						s add: m.
						s add: (FMSound new setPitch: 1 dur: 0.05 loudness: 0)]]].
	^ s play.

! !

!AbstractSound class methodsFor: 'utilities' stamp: 'DSM 9/5/2000 13:49'!
dialTone: duration
	"AbstractSound dialTone: 2"
	| m |
	m _ MixedSound new.
	m add: (FMSound new setPitch: 350 dur: duration loudness: 0.5).
	m add: (FMSound new setPitch: 440 dur: duration loudness: 0.5).
	m play.
	^ m! !

!AbstractSound class methodsFor: 'utilities' stamp: 'DSM 9/5/2000 13:50'!
hangUpWarning: count
	"AbstractSound hangUpWarning: 20"
	| m s |
	s _ SequentialSound new.
	m _ MixedSound new.
	m	add: (FMSound new setPitch: 1400 dur: 0.1 loudness: 0.5);
		add: (FMSound new setPitch: 2060 dur: 0.1 loudness: 0.5).
	s add: m; add: (FMSound new setPitch: 1 dur: 0.1 loudness: 0).
	^ (RepeatingSound repeat: s count: count) play

! !

!AbstractSound class methodsFor: 'utilities' stamp: 'jm 8/3/1998 16:16'!
indexOfBottomOctavePitch: p
	"Answer the index of the first pitch in the bottom octave equal to or higher than the given pitch. Assume that the given pitch is below the top pitch of the bottom octave."

	1 to: PitchesForBottomOctave size do: [:i |
		(PitchesForBottomOctave at: i) >= p ifTrue: [^ i]].
	self error: 'implementation error: argument pitch should be below or within the bottom octave'.
! !

!AbstractSound class methodsFor: 'utilities' stamp: 'jm 8/3/1998 16:16'!
midiKeyForPitch: pitchNameOrNumber
	"Answer the midiKey closest to the given pitch. Pitch may be a numeric pitch or a pitch name string such as 'c4'."
	"AbstractSound midiKeyForPitch: 440.0"

	| p octave i midiKey |
	pitchNameOrNumber isNumber
		ifTrue: [p _ pitchNameOrNumber asFloat]
		ifFalse: [p _ AbstractSound pitchForName: pitchNameOrNumber].
	octave _ -1.
	[p >= TopOfBottomOctave] whileTrue: [
		octave _ octave + 1.
		p _ p / 2.0].

	i _ self indexOfBottomOctavePitch: p.
	(i > 1) ifTrue: [
		(p - (PitchesForBottomOctave at: i - 1)) < ((PitchesForBottomOctave at: i) - p)
			ifTrue: [i _ i - 1]].

	midiKey _ ((octave * 12) + 11 + i).
	midiKey > 127 ifTrue: [midiKey _ 127].
	^ midiKey
! !

!AbstractSound class methodsFor: 'utilities' stamp: 'jm 8/3/1998 16:43'!
pitchForMIDIKey: midiKey
	"Answer the pitch for the given MIDI key."
	"(1 to: 127) collect: [:i | AbstractSound pitchForMIDIKey: i]"

	| indexInOctave octave |
	indexInOctave _ (midiKey \\ 12) + 1.
	octave _ (midiKey // 12) + 1.
	^ (PitchesForBottomOctave at: indexInOctave) *
		(#(1.0 2.0 4.0 8.0 16.0 32.0 64.0 128.0 256.0 512.0 1024.0) at: octave)
! !

!AbstractSound class methodsFor: 'utilities'!
pitchForName: aString
	"AbstractSound pitchForName: 'c2'"
	"#(c 'c#' d eb e f fs g 'g#' a bf b) collect: [ :s | AbstractSound pitchForName: s, '4']"

	| s modifier octave i j noteName p |
	s _ ReadStream on: aString.
	modifier _ $n.
	noteName _ s next.
	(s atEnd not and: [s peek isDigit]) ifFalse: [ modifier _ s next ].
	s atEnd
		ifTrue: [ octave _ 4 ]
		ifFalse: [ octave _ Integer readFrom: s ].
	octave < 0 ifTrue: [ self error: 'cannot use negative octave number' ].
	i _ 'cdefgab' indexOf: noteName.
	i = 0 ifTrue: [ self error: 'bad note name: ', noteName asString ].
	i _ #(2 4 6 7 9 11 13) at: i.
	j _ 's#fb' indexOf: modifier.
	j = 0 ifFalse: [ i _ i + (#(1 1 -1 -1) at: j) ].  "i is now in range: [1..14]"
	"Table generator: (1 to: 14) collect: [ :i | 16.3516 * (2.0 raisedTo: (i - 2) asFloat / 12.0)]"
	p _ #(15.4339 16.3516 17.3239 18.354 19.4454 20.6017 21.8268 23.1247 24.4997 25.9565 27.5 29.1352 30.8677 32.7032) at: i.
	octave timesRepeat: [ p _ 2.0 * p ].
	^ p
! !

!AbstractSound class methodsFor: 'utilities' stamp: 'jm 7/6/1998 15:47'!
pitchTable
	"AbstractSound pitchTable"

	| out note i |
	out _ WriteStream on: (String new: 1000).
	i _ 12.
	0 to: 8 do: [:octave |
		#(c 'c#' d eb e f fs g 'g#' a bf b) do: [:noteName |
			note _ noteName, octave printString.
			out nextPutAll: note; tab.
			out nextPutAll: i printString; tab.
			out nextPutAll: (AbstractSound pitchForName: note) printString; cr.
			i _ i + 1]].
	^ out contents
! !


!AbstractSound class methodsFor: 'examples' stamp: 'jm 6/30/1998 18:40'!
chromaticPitchesFrom: aPitch

	| halfStep pitch |
	halfStep _ 2.0 raisedTo: (1.0 / 12.0).
	pitch _ aPitch isNumber
			ifTrue: [aPitch]
			ifFalse: [self pitchForName: aPitch].
	pitch _ pitch / halfStep.
	^ (0 to: 14) collect: [:i | pitch _ pitch * halfStep]
! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 8/18/1998 11:32'!
chromaticRunFrom: startPitch to: endPitch on: aSound
	"Answer a composite sound consisting of a rapid chromatic run between the given pitches on the given sound."
	"(AbstractSound chromaticRunFrom: 'c3' to: 'c#5' on: FMSound oboe1) play"

	| scale halfStep pEnd p |
	scale _ SequentialSound new.
	halfStep _ 2.0 raisedTo: (1.0 / 12.0).
	endPitch isNumber
		ifTrue: [pEnd _ endPitch asFloat]
		ifFalse: [pEnd _ AbstractSound pitchForName: endPitch].
	startPitch isNumber
		ifTrue: [p _ startPitch asFloat]
		ifFalse: [p _ AbstractSound pitchForName: startPitch].
	[p <= pEnd] whileTrue: [
		scale add: (aSound soundForPitch: p dur: 0.2 loudness: 0.5).
		p _ p * halfStep].
	^ scale
! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/5/98 17:35'!
chromaticScale
	"PluckedSound chromaticScale play"

	^ self chromaticScaleOn: self default
! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/31/98 16:14'!
chromaticScaleOn: aSound
	"PluckedSound chromaticScale play"

	^ self noteSequenceOn: aSound
		from: (((self chromaticPitchesFrom: #c4) copyFrom: 1 to: 13)
			 collect: [:pitch | Array with: pitch with: 0.5 with: 300])
! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/5/98 17:36'!
hiMajorScale
	"FMSound hiMajorScale play"

	^ self hiMajorScaleOn: self default
! !

!AbstractSound class methodsFor: 'examples' stamp: 'di 1/30/98 16:00'!
hiMajorScaleOn: aSound
	"FMSound hiMajorScale play"

	^ self majorScaleOn: aSound from: #c6! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/5/98 17:36'!
lowMajorScale
	"PluckedSound lowMajorScale play"

	^ self lowMajorScaleOn: self default
! !

!AbstractSound class methodsFor: 'examples' stamp: 'di 1/30/98 16:01'!
lowMajorScaleOn: aSound
	"PluckedSound lowMajorScale play"

	^ self majorScaleOn: aSound from: #c3! !

!AbstractSound class methodsFor: 'examples' stamp: 'di 1/30/98 16:04'!
majorChord
	"FMSound majorChord play"
	^ self majorChordOn: self default from: #c4! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 8/3/1998 17:00'!
majorChordOn: aSound from: aPitch
	"FMSound majorChord play"

	| score majorScale leadingRest pan note |
	majorScale _ self majorPitchesFrom: aPitch.
	score _ MixedSound new.
	leadingRest _ pan _ 0.
	#(1 3 5 8) do: [:noteIndex |
		note _ aSound
			soundForPitch: (majorScale at: noteIndex)
			dur: 2.0 - leadingRest
			loudness: 0.3.
		score add: (RestSound dur: leadingRest), note pan: pan.
		leadingRest _ leadingRest + 0.2.
		pan _ pan + 0.3].
	^ score
! !

!AbstractSound class methodsFor: 'examples' stamp: 'di 1/30/98 14:45'!
majorPitchesFrom: aPitch
	| chromatic |
	chromatic _ self chromaticPitchesFrom: aPitch.
	^ #(1 3 5 6 8 10 12 13 15 13 12 10 8 6 5 3 1) collect: [:i | chromatic at: i].
! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/5/98 17:34'!
majorScale
	"FMSound majorScale play"

	^ self majorScaleOn: self default
! !

!AbstractSound class methodsFor: 'examples' stamp: 'di 1/30/98 16:00'!
majorScaleOn: aSound
	"FMSound majorScale play"

	^ self majorScaleOn: aSound from: #c5! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 7/13/1998 13:09'!
majorScaleOn: aSound from: aPitch
	"FMSound majorScale play"

	^ self noteSequenceOn: aSound
		from: ((self majorPitchesFrom: aPitch)
			 collect: [:pitch | Array with: pitch with: 0.5 with: 300])
! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/4/1999 09:26'!
majorScaleOn: aSound from: aPitch octaves: octaveCount
	"(AbstractSound majorScaleOn: FMSound oboe1 from: #c2 octaves: 5) play"

	| startingPitch pitches chromatic |
	startingPitch _ aPitch isNumber
		ifTrue: [aPitch]
		ifFalse: [self pitchForName: aPitch].
	pitches _ OrderedCollection new.
	0 to: octaveCount - 1 do: [:i |
		chromatic _ self chromaticPitchesFrom: startingPitch * (2 raisedTo: i).
		#(1 3 5 6 8 10 12) do: [:j | pitches addLast: (chromatic at: j)]].
	pitches addLast: startingPitch * (2 raisedTo: octaveCount).
	^ self noteSequenceOn: aSound
		from: (pitches collect: [:pitch | Array with: pitch with: 0.5 with: 300])
! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/5/98 17:32'!
scaleTest
	"AbstractSound scaleTest play"

	^ MixedSound new
		add: FMSound majorScale pan: 0;
		add: (PluckedSound lowMajorScale delayedBy: 0.5) pan: 1.0.
! !

!AbstractSound class methodsFor: 'examples' stamp: 'di 4/13/1999 13:53'!
testFMInteractively
	"Experiment with different settings of the FM modulation and multiplier settings interactively by moving the mouse. The top-left corner of the screen is 0 for both parameters. Stop when the mouse is pressed."
	"AbstractSound testFMInteractively"

	| s mousePt lastVal status mod ratio |
	SoundPlayer startPlayerProcessBufferSize: 1100 rate: 11025 stereo: false.
	s _ FMSound pitch: 440.0 dur: 200.0 loudness: 0.2.

	SoundPlayer playSound: s.
	lastVal _ nil.
	[Sensor anyButtonPressed] whileFalse: [
		mousePt _ Sensor cursorPoint.
		mousePt ~= lastVal ifTrue: [
			mod _ mousePt x asFloat / 20.0.
			ratio _ mousePt y asFloat / 20.0.
			s modulation: mod ratio: ratio.
			lastVal _ mousePt.
			status _
'mod: ', mod printString, '
ratio: ', ratio printString.
			status displayOn: Display at: 10@10]].

	SoundPlayer shutDown.
! !


!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 1/5/98 17:38'!
bachFugue
	"Play a fugue by J. S. Bach using and instance of me as the sound for all four voices."
	"PluckedSound bachFugue play"

	^ self bachFugueOn: self default
! !

!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 1/5/98 18:27'!
bachFugueOn: aSound
	"Play a fugue by J. S. Bach using the given sound as the sound for all four voices."
	"PluckedSound bachFugue play"

	^ MixedSound new
		add: (self bachFugueVoice1On: aSound) pan: 1.0;
		add: (self bachFugueVoice2On: aSound) pan: 0.0;
		add: (self bachFugueVoice3On: aSound) pan: 1.0;
		add: (self bachFugueVoice4On: aSound) pan: 0.0.
! !

!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 12/17/97 16:51'!
bachFugueVoice1On: aSound
	"Voice one of a fugue by J. S. Bach."

	^ self noteSequenceOn: aSound from: #(
		(1047 0.15 268)
		(988  0.15 268)
		(1047 0.30 268)
		(784  0.30 268)
		(831  0.30 268)
		(1047 0.15 268)
		(988  0.15 268)
		(1047 0.30 268)
		(1175 0.30 268)
		(784  0.30 268)
		(1047 0.15 268)
		(988  0.15 268)
		(1047 0.30 268)
		(1175 0.30 268)
		(698  0.15 268)
		(784  0.15 268)
		(831  0.60 268)
		(784  0.15 268)
		(698  0.15 268)
		(622  0.15 268)
		(1047 0.15 268)
		(988  0.15 268)
		(880  0.15 268)
		(784  0.15 268)
		(698  0.15 268)
		(622  0.15 268)
		(587  0.15 268)
		(523  0.30 268)
		(1245 0.30 268)
		(1175 0.30 268)
		(1047 0.30 268)
		(932  0.30 268)
		(880  0.30 268)
		(932  0.30 268)
		(1047 0.30 268)
		(740  0.30 268)
		(784  0.30 268)
		(880  0.30 268)
		(740  0.30 268)
		(784  0.60 268)
		(rest 0.15)
		(523  0.15 268)
		(587  0.15 268)
		(622  0.15 268)
		(698  0.15 268)
		(784  0.15 268)
		(831  0.45 268)
		(587  0.15 268)
		(622  0.15 268)
		(698  0.15 268)
		(784  0.15 268)
		(880  0.15 268)
		(932  0.45 268)
		(622  0.15 268)
		(698  0.15 268)
		(784  0.15 268)
		(831  0.15 268)
		(784  0.15 268)
		(698  0.15 268)
		(622  0.15 268)
		(587  0.30 268)
		(1047 0.15 268)
		(988  0.15 268)
		(1047 0.60 268)
		(rest 0.9)
		(1397 0.30 268)
		(1245 0.30 268)
		(1175 0.30 268)
		(rest 0.3)
		(831  0.30 268)
		(784  0.30 268)
		(698  0.30 268)
		(784  0.30 268)
		(698  0.15 268)
		(622  0.15 268)
		(698  0.30 268)
		(587  0.30 268)
		(784  0.60 268)
		(rest 0.3)
		(988  0.30 268)
		(1047 0.30 268)
		(1047 0.15 268)
		(988  0.15 268)
		(1047 0.30 268)
		(784  0.30 268)
		(831  0.60 268)
		(rest 0.3)
		(880  0.30 268)
		(932  0.30 268)
		(932  0.15 268)
		(880  0.15 268)
		(932  0.30 268)
		(698  0.30 268)
		(784  0.60 268)
		(rest 0.3)
		(784  0.30 268)
		(831  0.30 268)
		(831  0.30 268)
		(784  0.30 268)
		(698  0.30 268)
		(rest 0.3)
		(415  0.30 268)
		(466  0.30 268)
		(523  0.30 268)
		(rest 0.3)
		(415  0.15 268)
		(392  0.15 268)
		(415  0.30 268)
		(349  0.30 268)
		(466  0.30 268)
		(523  0.30 268)
		(466  0.30 268)
		(415  0.30 268)
		(466  0.30 268)
		(392  0.30 268)
		(349  0.30 268)
		(311  0.30 268)
		(349  0.30 268)
		(554  0.30 268)
		(523  0.30 268)
		(466  0.30 268)
		(523  0.30 268)
		(415  0.30 268)
		(392  0.30 268)
		(349  0.30 268)
		(392  0.30 268)
		(784  0.15 268)
		(740  0.15 268)
		(784  0.30 268)
		(523  0.30 268)
		(622  0.30 268)
		(784  0.15 268)
		(740  0.15 268)
		(784  0.30 268)
		(880  0.30 268)
		(587  0.30 268)
		(784  0.15 268)
		(740  0.15 268)
		(784  0.30 268)
		(880  0.30 268)
		(523  0.15 268)
		(587  0.15 268)
		(622  0.60 268)
		(587  0.15 268)
		(523  0.15 268)
		(466  0.30 346)
		(rest 0.45)
		(587  0.15 346)
		(659  0.15 346)
		(740  0.15 346)
		(784  0.15 346)
		(880  0.15 346)
		(932  0.45 346)
		(659  0.15 346)
		(698  0.15 346)
		(784  0.15 346)
		(880  0.15 346)
		(932  0.15 346)
		(1047 0.45 346)
		(740  0.15 346)
		(784  0.15 346)
		(880  0.15 346)
		(932  0.30 346)
		(622  0.15 346)
		(587  0.15 346)
		(622  0.30 346)
		(392  0.30 346)
		(415  0.30 346)
		(698  0.15 346)
		(622  0.15 346)
		(698  0.30 346)
		(440  0.30 346)
		(466  0.30 346)
		(784  0.15 346)
		(698  0.15 346)
		(784  0.30 346)
		(494  0.30 346)
		(523  0.15 346)
		(698  0.15 346)
		(622  0.15 346)
		(587  0.15 346)
		(523  0.15 346)
		(466  0.15 346)
		(440  0.15 346)
		(392  0.15 346)
		(349  0.30 346)
		(831  0.30 346)
		(784  0.30 346)
		(698  0.30 346)
		(622  0.30 346)
		(587  0.30 346)
		(622  0.30 346)
		(698  0.30 346)
		(494  0.30 346)
		(523  0.30 346)
		(587  0.30 346)
		(494  0.30 346)
		(523  0.60 346)
		(rest 0.3)
		(659  0.30 346)
		(698  0.30 346)
		(698  0.15 346)
		(659  0.15 346)
		(698  0.30 346)
		(523  0.30 346)
		(587  0.60 346)
		(rest 0.3)
		(587  0.30 346)
		(622  0.30 346)
		(622  0.15 346)
		(587  0.15 346)
		(622  0.30 346)
		(466  0.30 346)
		(523  1.20 346)
		(523  0.30 346)
		(587  0.15 346)
		(622  0.15 346)
		(698  0.15 346)
		(622  0.15 346)
		(698  0.15 346)
		(587  0.15 346)
		(494  0.30 457)
		(rest 0.6)
		(494  0.30 457)
		(523  0.30 457)
		(rest 0.6)
		(622  0.30 457)
		(587  0.30 457)
		(rest 0.6)
		(698  0.60 457)
		(rest 0.6)
		(698  0.30 457)
		(622  0.30 457)
		(831  0.30 457)
		(784  0.30 457)
		(698  0.30 457)
		(622  0.30 457)
		(587  0.30 457)
		(622  0.30 457)
		(698  0.30 457)
		(494  0.30 457)
		(523  0.30 457)
		(587  0.30 457)
		(494  0.30 457)
		(494  0.30 457)
		(523  0.30 457)
		(rest 0.3)
		(523  0.30 457)
		(698  0.15 457)
		(587  0.15 457)
		(622  0.15 457)
		(523  0.45 457)
		(494  0.30 457)
		(523  0.60 457)
		(rest 0.3)
		(659  0.30 268)
		(698  0.60 268)
		(rest 0.3)
		(698  0.30 268)
		(698  0.30 268)
		(622  0.15 268)
		(587  0.15 268)
		(622  0.30 268)
		(698  0.30 268)
		(587  0.40 268)
		(rest 0.4)
		(587  0.40 268)
		(rest 0.4)
		(523  1.60 268)).! !

!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 12/17/97 16:52'!
bachFugueVoice2On: aSound
	"Voice two of a fugue by J. S. Bach."

	^ self noteSequenceOn: aSound from: #(
		(rest 4.8)
		(1568 0.15 346)
		(1480 0.15 346)
		(1568 0.30 346)
		(1047 0.30 346)
		(1245 0.30 346)
		(1568 0.15 346)
		(1480 0.15 346)
		(1568 0.30 346)
		(1760 0.30 346)
		(1175 0.30 346)
		(1568 0.15 346)
		(1480 0.15 346)
		(1568 0.30 346)
		(1760 0.30 346)
		(1047 0.15 346)
		(1175 0.15 346)
		(1245 0.60 346)
		(1175 0.15 346)
		(1047 0.15 346)
		(932  0.30 346)
		(1245 0.15 346)
		(1175 0.15 346)
		(1245 0.30 346)
		(784  0.30 346)
		(831  0.30 346)
		(1397 0.15 346)
		(1245 0.15 346)
		(1397 0.30 346)
		(880  0.30 346)
		(932  0.30 346)
		(1568 0.15 346)
		(1397 0.15 346)
		(1568 0.30 346)
		(988  0.30 346)
		(1047 0.30 346)
		(1175 0.15 346)
		(1245 0.15 346)
		(1397 0.90 346)
		(1245 0.15 346)
		(1175 0.15 346)
		(1047 0.15 346)
		(932  0.15 346)
		(831  0.15 346)
		(784  0.15 346)
		(698  0.30 346)
		(1661 0.30 346)
		(1568 0.30 346)
		(1397 0.30 346)
		(1245 0.30 346)
		(1175 0.30 346)
		(1245 0.30 346)
		(1397 0.30 346)
		(988  0.30 346)
		(1047 0.30 346)
		(1175 0.30 346)
		(988  0.30 346)
		(1047 0.30 457)
		(1568 0.15 457)
		(1480 0.15 457)
		(1568 0.30 457)
		(1175 0.30 457)
		(1245 0.60 457)
		(rest 0.3)
		(1319 0.30 457)
		(1397 0.30 457)
		(1397 0.15 457)
		(1319 0.15 457)
		(1397 0.30 457)
		(1047 0.30 457)
		(1175 0.60 457)
		(rest 0.3)
		(1175 0.30 457)
		(1245 0.30 457)
		(1245 0.15 457)
		(1175 0.15 457)
		(1245 0.30 457)
		(932  0.30 457)
		(1047 0.30 457)
		(1245 0.15 457)
		(1175 0.15 457)
		(1245 0.30 457)
		(1397 0.30 457)
		(932  0.30 457)
		(1245 0.15 457)
		(1175 0.15 457)
		(1245 0.30 457)
		(1397 0.30 457)
		(831  0.15 457)
		(932  0.15 457)
		(1047 0.60 457)
		(932  0.15 457)
		(831  0.15 457)
		(784  0.15 457)
		(622  0.15 457)
		(698  0.15 457)
		(784  0.15 457)
		(831  0.15 457)
		(932  0.15 457)
		(1047 0.15 457)
		(1175 0.15 457)
		(1245 0.15 457)
		(1175 0.15 457)
		(1047 0.15 457)
		(1175 0.15 457)
		(1245 0.15 457)
		(1397 0.15 457)
		(1568 0.15 457)
		(1760 0.15 457)
		(1865 0.15 457)
		(698  0.15 457)
		(784  0.15 457)
		(831  0.15 457)
		(932  0.15 457)
		(1047 0.15 457)
		(1175 0.15 457)
		(1319 0.15 457)
		(1397 0.15 457)
		(1245 0.15 457)
		(1175 0.15 457)
		(1245 0.15 457)
		(1397 0.15 457)
		(1568 0.15 457)
		(1760 0.15 457)
		(1976 0.15 457)
		(2093 0.30 457)
		(1976 0.15 457)
		(1760 0.15 457)
		(1568 0.15 457)
		(1397 0.15 457)
		(1245 0.15 457)
		(1175 0.15 457)
		(1047 0.30 457)
		(1245 0.30 457)
		(1175 0.30 457)
		(1047 0.30 457)
		(932  0.30 457)
		(880  0.30 457)
		(932  0.30 457)
		(1047 0.30 457)
		(740  0.30 457)
		(784  0.30 457)
		(880  0.30 457)
		(740  0.30 457)
		(784  0.30 457)
		(1175 0.15 457)
		(1047 0.15 457)
		(1175 0.30 457)
		(rest 0.6)
		(1319 0.15 457)
		(1175 0.15 457)
		(1319 0.30 457)
		(rest 0.6)
		(1480 0.15 457)
		(1319 0.15 457)
		(1480 0.30 457)
		(rest 0.6)
		(784  0.15 457)
		(698  0.15 457)
		(784  0.30 457)
		(rest 0.6)
		(880  0.15 457)
		(784  0.15 457)
		(880  0.30 457)
		(rest 0.6)
		(988  0.15 457)
		(880  0.15 457)
		(988  0.30 457)
		(rest 0.6)
		(1047 0.15 457)
		(988  0.15 457)
		(1047 0.30 457)
		(784  0.30 457)
		(831  0.30 457)
		(1047 0.15 457)
		(988  0.15 457)
		(1047 0.30 457)
		(1175 0.30 457)
		(784  0.30 457)
		(1047 0.15 457)
		(988  0.15 457)
		(1047 0.30 457)
		(1175 0.30 457)
		(698  0.15 457)
		(784  0.15 457)
		(831  0.60 457)
		(784  0.15 457)
		(698  0.15 457)
		(622  0.30 457)
		(1047 0.15 457)
		(988  0.15 457)
		(1047 0.30 457)
		(784  0.30 457)
		(831  0.60 457)
		(rest 0.3)
		(880  0.30 457)
		(932  0.30 457)
		(932  0.15 457)
		(880  0.15 457)
		(932  0.30 457)
		(698  0.30 457)
		(784  0.60 457)
		(rest 0.3)
		(784  0.60 457)
		(831  0.15 457)
		(932  0.15 457)
		(1047 0.15 457)
		(988  0.15 457)
		(1047 0.15 457)
		(831  0.15 457)
		(698  1.20 457)
		(698  0.30 591)
		(1175 0.15 591)
		(1047 0.15 591)
		(1175 0.30 591)
		(698  0.30 591)
		(622  0.30 591)
		(1245 0.15 591)
		(1175 0.15 591)
		(1245 0.30 591)
		(784  0.30 591)
		(698  0.30 591)
		(1397 0.15 591)
		(1245 0.15 591)
		(1397 0.30 591)
		(831  0.30 591)
		(784  0.15 591)
		(1397 0.15 591)
		(1245 0.15 591)
		(1175 0.15 591)
		(1047 0.15 591)
		(988  0.15 591)
		(880  0.15 591)
		(784  0.15 591)
		(1047 0.30 591)
		(1397 0.30 591)
		(1245 0.30 591)
		(1175 0.30 591)
		(rest 0.3)
		(831  0.30 591)
		(784  0.30 591)
		(698  0.30 591)
		(784  0.30 591)
		(698  0.15 591)
		(622  0.15 591)
		(698  0.30 591)
		(587  0.30 591)
		(831  0.30 591)
		(784  0.30 591)
		(rest 0.3)
		(880  0.30 591)
		(988  0.30 591)
		(1047 0.30 591)
		(698  0.15 591)
		(622  0.15 591)
		(587  0.15 591)
		(523  0.15 591)
		(523  0.30 591)
		(1047 0.15 346)
		(988  0.15 346)
		(1047 0.30 346)
		(784  0.30 346)
		(831  0.30 346)
		(1047 0.15 346)
		(988  0.15 346)
		(1047 0.30 346)
		(1175 0.30 346)
		(784  0.30 346)
		(1047 0.15 346)
		(988  0.15 346)
		(1047 0.30 346)
		(1175 0.30 346)
		(698  0.20 346)
		(784  0.20 346)
		(831  0.80 346)
		(784  0.20 346)
		(698  0.20 346)
		(659  1.60 346)).
! !

!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 12/17/97 16:52'!
bachFugueVoice3On: aSound
	"Voice three of a fugue by J. S. Bach."

	^ self noteSequenceOn: aSound from: #(
		(rest 14.4)
		(523  0.15 457)
		(494  0.15 457)
		(523  0.30 457)
		(392  0.30 457)
		(415  0.30 457)
		(523  0.15 457)
		(494  0.15 457)
		(523  0.30 457)
		(587  0.30 457)
		(392  0.30 457)
		(523  0.15 457)
		(494  0.15 457)
		(523  0.30 457)
		(587  0.30 457)
		(349  0.15 457)
		(392  0.15 457)
		(415  0.60 457)
		(392  0.15 457)
		(349  0.15 457)
		(311  0.15 457)
		(523  0.15 457)
		(494  0.15 457)
		(440  0.15 457)
		(392  0.15 457)
		(349  0.15 457)
		(311  0.15 457)
		(294  0.15 457)
		(262  0.15 457)
		(294  0.15 457)
		(311  0.15 457)
		(294  0.15 457)
		(262  0.15 457)
		(233  0.15 457)
		(208  0.15 457)
		(196  0.15 457)
		(175  0.15 457)
		(466  0.15 457)
		(415  0.15 457)
		(392  0.15 457)
		(349  0.15 457)
		(311  0.15 457)
		(294  0.15 457)
		(262  0.15 457)
		(233  0.15 457)
		(262  0.15 457)
		(294  0.15 457)
		(262  0.15 457)
		(233  0.15 457)
		(208  0.15 457)
		(196  0.15 457)
		(175  0.15 457)
		(156  0.15 457)
		(415  0.15 457)
		(392  0.15 457)
		(349  0.15 457)
		(311  0.15 457)
		(277  0.15 457)
		(262  0.15 457)
		(233  0.15 457)
		(208  0.30 457)
		(523  0.30 457)
		(466  0.30 457)
		(415  0.30 457)
		(392  0.30 457)
		(349  0.30 457)
		(392  0.30 457)
		(415  0.30 457)
		(294  0.30 457)
		(311  0.30 457)
		(349  0.30 457)
		(294  0.30 457)
		(311  0.30 457)
		(415  0.30 457)
		(392  0.30 457)
		(349  0.30 457)
		(392  0.30 457)
		(311  0.30 457)
		(294  0.30 457)
		(262  0.30 457)
		(294  0.30 457)
		(466  0.30 457)
		(415  0.30 457)
		(392  0.30 457)
		(415  0.30 457)
		(349  0.30 457)
		(311  0.30 457)
		(294  0.30 457)
		(311  0.30 457)
		(rest 1.2)
		(262  0.30 457)
		(233  0.30 457)
		(220  0.30 457)
		(rest 0.3)
		(311  0.30 457)
		(294  0.30 457)
		(262  0.30 457)
		(294  0.30 457)
		(262  0.15 457)
		(233  0.15 457)
		(262  0.30 457)
		(294  0.30 457)
		(196  0.30 591)
		(466  0.15 591)
		(440  0.15 591)
		(466  0.30 591)
		(294  0.30 591)
		(311  0.30 591)
		(523  0.15 591)
		(466  0.15 591)
		(523  0.30 591)
		(330  0.30 591)
		(349  0.30 591)
		(587  0.15 591)
		(523  0.15 591)
		(587  0.30 591)
		(370  0.30 591)
		(392  0.60 591)
		(rest 0.15)
		(196  0.15 591)
		(220  0.15 591)
		(247  0.15 591)
		(262  0.15 591)
		(294  0.15 591)
		(311  0.45 591)
		(220  0.15 591)
		(233  0.15 591)
		(262  0.15 591)
		(294  0.15 591)
		(311  0.15 591)
		(349  0.45 591)
		(247  0.15 591)
		(262  0.15 591)
		(294  0.15 591)
		(311  0.30 591)
		(rest 0.6)
		(330  0.30 591)
		(349  0.30 591)
		(175  0.30 591)
		(156  0.30 591)
		(147  0.30 591)
		(rest 0.3)
		(208  0.30 591)
		(196  0.30 591)
		(175  0.30 591)
		(196  0.30 591)
		(175  0.15 591)
		(156  0.15 591)
		(175  0.30 591)
		(196  0.30 591)
		(262  0.15 591)
		(294  0.15 591)
		(311  0.15 591)
		(294  0.15 591)
		(262  0.15 591)
		(233  0.15 591)
		(208  0.15 591)
		(196  0.15 591)
		(175  0.15 591)
		(466  0.15 591)
		(415  0.15 591)
		(392  0.15 591)
		(349  0.15 591)
		(311  0.15 591)
		(294  0.15 591)
		(262  0.15 591)
		(233  0.15 591)
		(262  0.15 591)
		(294  0.15 591)
		(262  0.15 591)
		(233  0.15 591)
		(208  0.15 591)
		(196  0.15 591)
		(175  0.15 591)
		(156  0.15 591)
		(415  0.15 591)
		(392  0.15 591)
		(349  0.15 591)
		(311  0.15 591)
		(294  0.15 591)
		(262  0.15 591)
		(233  0.15 591)
		(208  0.15 591)
		(233  0.15 591)
		(262  0.15 591)
		(233  0.15 591)
		(208  0.15 591)
		(196  0.15 591)
		(175  0.15 591)
		(156  0.15 591)
		(147  0.15 591)
		(392  0.15 591)
		(349  0.15 591)
		(311  0.15 591)
		(294  0.15 591)
		(262  0.15 591)
		(247  0.15 591)
		(220  0.15 591)
		(196  0.60 772)
		(196  0.60 772)
		(rest 0.15)
		(196  0.15 772)
		(220  0.15 772)
		(247  0.15 772)
		(262  0.15 772)
		(294  0.15 772)
		(311  0.15 772)
		(349  0.15 772)
		(392  0.15 772)
		(349  0.15 772)
		(415  0.15 772)
		(392  0.15 772)
		(349  0.15 772)
		(311  0.15 772)
		(294  0.15 772)
		(262  0.15 772)
		(247  0.30 772)
		(262  0.15 772)
		(494  0.15 772)
		(262  0.30 772)
		(196  0.30 772)
		(208  0.30 772)
		(262  0.15 772)
		(247  0.15 772)
		(262  0.30 772)
		(294  0.30 772)
		(196  0.30 772)
		(262  0.15 772)
		(247  0.15 772)
		(262  0.30 772)
		(294  0.30 772)
		(175  0.15 772)
		(196  0.15 772)
		(208  0.60 772)
		(196  0.15 772)
		(175  0.15 772)
		(156  0.60 772)
		(rest 0.3)
		(311  0.30 772)
		(294  0.30 772)
		(262  0.30 772)
		(392  0.30 772)
		(196  0.30 772)
		(262  3.60 268)
		(494  0.40 268)
		(rest 0.4)
		(494  0.40 268)
		(rest 0.4)
		(392  1.60 268)).
! !

!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 12/17/97 16:52'!
bachFugueVoice4On: aSound
	"Voice four of a fugue by J. S. Bach."

	^ self noteSequenceOn: aSound from: #(
		(rest 61.2)
		(131  0.15 500)
		(123  0.15 500)
		(131  0.30 500)
		(98   0.30 500)
		(104  0.30 500)
		(131  0.15 500)
		(123  0.15 500)
		(131  0.30 500)
		(147  0.30 500)
		(98   0.30 500)
		(131  0.15 500)
		(123  0.15 500)
		(131  0.30 500)
		(147  0.30 500)
		(87   0.15 500)
		(98   0.15 500)
		(104  0.60 500)
		(98   0.15 500)
		(87   0.15 500)
		(78   0.60 500)
		(rest 0.3)
		(156  0.30 500)
		(147  0.30 500)
		(131  0.30 500)
		(196  0.30 500)
		(98   0.30 500)
		(131  3.60 268)
		(131  3.20 205)).
! !

!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 1/5/98 17:45'!
stereoBachFugue
	"Play fugue by J. S. Bach in stereo using different timbres."
	"AbstractSound stereoBachFugue play"

	"(AbstractSound bachFugueVoice1On: FMSound flute1) play"
	"(AbstractSound bachFugueVoice1On: PluckedSound default) play"

	^ MixedSound new
		add: (self bachFugueVoice1On: FMSound oboe1) pan: 0.2;
		add: (self bachFugueVoice2On: FMSound organ1) pan: 0.8;
		add: (self bachFugueVoice3On: PluckedSound default) pan: 0.4;
		add: (self bachFugueVoice4On: FMSound brass1) pan: 0.6.
! !


!AbstractSound class methodsFor: 'sound library' stamp: 'jm 8/14/1998 13:27'!
initSounds
	"AbstractSound initSounds"

	Sounds _ Dictionary new.
	(FMSound class organization listAtCategoryNamed: #instruments)
		do: [:sel | Sounds at: sel asString put: (FMSound perform: sel)].
! !

!AbstractSound class methodsFor: 'sound library' stamp: 'jm 8/14/1998 13:25'!
soundNamed: soundName

	^ Sounds at: soundName
! !

!AbstractSound class methodsFor: 'sound library' stamp: 'jm 3/4/98 10:29'!
soundNamed: soundName ifAbsent: aBlock

	^ Sounds at: soundName ifAbsent: aBlock
! !

!AbstractSound class methodsFor: 'sound library' stamp: 'di 11/7/2000 12:12'!
soundNamed: soundName put: aSound

	Sounds at: soundName put: aSound.
	AbstractSound updateScorePlayers.
! !

!AbstractSound class methodsFor: 'sound library' stamp: 'jm 8/19/1998 14:11'!
soundNames

	^ Sounds keys asSortedCollection asArray
! !

!AbstractSound class methodsFor: 'sound library' stamp: 'jm 8/4/1998 18:26'!
sounds

	^ Sounds
! !

!AbstractSound class methodsFor: 'sound library' stamp: 'jm 1/14/1999 13:00'!
updateFMSounds
	"AbstractSound updateFMSounds"

	Sounds keys do: [:k |
		((Sounds at: k) isKindOf: FMSound) ifTrue: [
			Sounds removeKey: k ifAbsent: []]].

	(FMSound class organization listAtCategoryNamed: #instruments) do:
		[:sel | Sounds at: sel asString put: (FMSound perform: sel)].
! !


!AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'sge 2/13/2000 05:20'!
fileInSoundLibrary
	"Prompt the user for a file name and the file in the sound library with that name."
	"AbstractSound fileInSoundLibrary"

	| fileName |
	fileName _ FillInTheBlank request: 'Sound library file name?'.
	fileName isEmptyOrNil ifTrue: [^ self].
	(fileName endsWith: '.sounds') ifFalse: [fileName _ fileName, '.sounds'].
	self fileInSoundLibraryNamed: fileName.
! !

!AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'kks 9/27/2007 16:25'!
fileInSoundLibraryNamed: fileName
	"File in the sound library with the given file name, and add its contents to the current sound library."

	| s newSounds |
	s _ FileStream readOnlyFileNamed: fileName.
	newSounds _ s fileInObjectAndCode.
	s close.
	newSounds associationsDo:
		[:assoc | self storeFiledInSound: assoc value named: assoc key].
	AbstractSound updateScorePlayers.
	Smalltalk garbageCollect.  "Large objects may have been released"
! !

!AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'jm 8/19/1998 12:42'!
fileOutSoundLibrary
	"File out the current sound library."
	"AbstractSound fileOutSoundLibrary"

	self fileOutSoundLibrary: Sounds.
! !

!AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'sge 2/13/2000 05:22'!
fileOutSoundLibrary: aDictionary
	"File out the given dictionary, which is assumed to contain sound and instrument objects keyed by their names."
	"Note: This method is separated out so that one can file out edited sound libraries, as well as the system sound library. To make such a collection, you can inspect AbstractSound sounds and remove the items you don't want. Then do: 'AbstractSound fileOutSoundLibrary: self' from the Dictionary inspector."

	| fileName refStream |
	(aDictionary isKindOf: Dictionary)
		ifFalse: [self error: 'arg should be a dictionary of sounds'].
	fileName _ FillInTheBlank request: 'Sound library file name?'.
	fileName isEmptyOrNil ifTrue: [^ self].
	refStream _ SmartRefStream fileNamed: fileName, '.sounds'.
	refStream nextPut: aDictionary.
	refStream close.
! !

!AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'jm 9/12/1998 21:35'!
storeFiledInSound: snd named: sndName
	"Store the given sound in the sound library. Use the given name if it isn't in use, otherwise ask the user what to do."

	| menu choice i |
	(Sounds includesKey: sndName) ifFalse: [  "no name clash"
		Sounds at: sndName put: snd.
		^ self].

	(Sounds at: sndName) == UnloadedSnd ifTrue: [
		"re-loading a sound that was unloaded to save space"
		Sounds at: sndName put: snd.
		^ self].

	"the given sound name is already used"
	menu _ SelectionMenu selections:
		#('replace the existing sound' 'rename the new sound' 'skip it').
	choice _ menu startUpWithCaption:
		'"', sndName, '" has the same name as an existing sound'.
	(choice beginsWith: 'replace') ifTrue: [
		Sounds at: sndName put: snd.
		^ self].
	(choice beginsWith: 'rename') ifTrue: [
		i _ 2.
		[Sounds includesKey: (sndName, ' v', i printString)] whileTrue: [i _ i + 1].
		Sounds at: (sndName, ' v', i printString) put: snd].
! !

!AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'jm 9/12/1998 22:18'!
unloadSampledTimbres
	"This can be done to unload those bulky sampled timbres to shrink the image. The unloaded sounds are replaced by a well-known 'unloaded sound' object to enable the unloaded sounds to be detected when the process is reversed."
	"AbstractSound unloadSampledTimbres"

	Sounds keys copy do: [:soundName |
		(((Sounds at: soundName) isKindOf: SampledInstrument) or:
		 [(Sounds at: soundName) isKindOf: LoopedSampledSound]) ifTrue: [
			Sounds at: soundName put: self unloadedSound]].
	self updateScorePlayers.
	Smalltalk garbageCollect.
! !

!AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'jm 9/11/1998 16:47'!
unloadSoundNamed: soundName

	(Sounds includesKey: soundName) ifTrue: [
		Sounds at: soundName put: self unloadedSound].
	self updateScorePlayers.
! !

!AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'jm 9/12/1998 21:48'!
unloadedSound
	"Answer a sound to be used as the place-holder for sounds that have been unloaded."

	UnloadedSnd ifNil: [UnloadedSnd _ UnloadedSound default copy].
	^ UnloadedSnd
! !

!AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'di 11/7/2000 13:00'!
updateScorePlayers
	| soundsBeingEdited |
	"Force all ScorePlayers to update their instrument list from the sound library. This may done after loading, unloading, or replacing a sound to make all ScorePlayers feel the change."

	ScorePlayer allSubInstancesDo:
		[:p | p pause].
	SoundPlayer shutDown.
	soundsBeingEdited _ EnvelopeEditorMorph allSubInstances collect: [:ed | ed soundBeingEdited].
	ScorePlayerMorph allSubInstancesDo:
		[:p | p updateInstrumentsFromLibraryExcept: soundsBeingEdited].
! !


!AbstractSound class methodsFor: 'primitive generation' stamp: 'ar 2/3/2001 15:30'!
translatedPrimitives
	^#(
		(FMSound mixSampleCount:into:startingAt:leftVol:rightVol:)
		(PluckedSound mixSampleCount:into:startingAt:leftVol:rightVol:)
		(LoopedSampledSound mixSampleCount:into:startingAt:leftVol:rightVol:)
		(SampledSound mixSampleCount:into:startingAt:leftVol:rightVol:)
		(ReverbSound applyReverbTo:startingAt:count:)
	).
! !
Object subclass: #AbstractSoundSystem
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!
!AbstractSoundSystem commentStamp: 'gk 2/24/2004 08:34' prior: 0!
This is the abstract base class for a sound system. A sound system offers a small protocol for playing sounds and making beeps and works like a facade towards the rest of Squeak. A sound system is registered in the application registry SoundService and can be accessed by "SoundService default" like for example:

SoundService default playSoundNamed: 'croak'

The idea is that as much sound playing as possible should go through this facade. This way we decouple the sound system from the rest of Squeak and make it pluggable. It also is a perfect spot to check for the Preference class>>soundsEnabled.

Two basic subclasses exist at the time of this writing, the BaseSoundSystem which represents the standard Squeak sound system, and the DummySoundSystem which is a dummy implementation that can be used when there is no sound card available, or when the base sound system isn't in the image, or when you simply don't want to use the available sound card.!


!AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/24/2004 23:27'!
beep
	"Make a primitive beep."

	self subclassResponsibility! !

!AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:47'!
playSampledSound: samples rate: rate

	self subclassResponsibility! !

!AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:50'!
playSoundNamed: soundName

	self subclassResponsibility! !

!AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:51'!
playSoundNamed: soundName ifAbsentReadFrom: aifFileName

	self subclassResponsibility! !

!AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:51'!
playSoundNamedOrBeep: soundName

	self subclassResponsibility! !


!AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:52'!
randomBitsFromSoundInput: bitCount

	self subclassResponsibility! !

!AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:52'!
sampledSoundChoices

	self subclassResponsibility! !

!AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:53'!
shutDown
	"Default is to do nothing."! !

!AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:56'!
soundNamed: soundName

	self subclassResponsibility! !
PluggableTextMorph subclass: #AcceptableCleanTextMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!

!AcceptableCleanTextMorph methodsFor: 'menu commands' stamp: 'dgd 2/21/2003 22:50'!
accept
	"Overridden to allow accept of clean text"

	| textToAccept ok |
	textToAccept := textMorph asText.
	ok := setTextSelector isNil or: 
					[setTextSelector numArgs = 2 
						ifTrue: 
							[model 
								perform: setTextSelector
								with: textToAccept
								with: self]
						ifFalse: [model perform: setTextSelector with: textToAccept]].
	ok 
		ifTrue: 
			[self setText: self getText.
			self hasUnacceptedEdits: false]! !
FileDirectory subclass: #AcornFileDirectory
	instanceVariableNames: ''
	classVariableNames: 'LegalCharMap'
	poolDictionaries: ''
	category: 'System-Files'!

!AcornFileDirectory methodsFor: 'file name utilities' stamp: 'tpr 12/23/2004 19:21'!
checkName: aFileName fixErrors: fixing
	"Check if the file name contains any invalid characters"
	| fName hasBadChars correctedName newChar|
	fName _ super checkName: aFileName fixErrors: fixing.
	correctedName _ String streamContents:[:s|
								fName do:[:c|
									(newChar _ LegalCharMap at: c asciiValue +1) ifNotNil:[s nextPut: newChar]]]. 
	hasBadChars _ fName ~= correctedName.
	(hasBadChars and:[fixing not]) ifTrue:[^self error:'Invalid file name'].
	hasBadChars ifFalse:[^ fName].
	^ correctedName! !

!AcornFileDirectory methodsFor: 'file name utilities' stamp: 'tpr 11/5/2004 13:08'!
fullPathFor: path
	"if the arg is an empty string, just return my path name converted via the language stuff. 
If the arg seems to be a  rooted path, return it raw, assuming it is already ok.
Otherwise cons up a path"
	path isEmpty ifTrue:[^pathName asSqueakPathName].
	((path includes: $$ ) or:[path includes: $:]) ifTrue:[^path].
	^pathName asSqueakPathName, self slash, path! !


!AcornFileDirectory methodsFor: 'private' stamp: 'tpr 11/5/2004 13:08'!
directoryContentsFor: fullPath 
	"Return a collection of directory entries for the files and directories in 
	the directory with the given path. See primLookupEntryIn:index: for 
	further details."
	"FileDirectory default directoryContentsFor: ''"

	| entries extraPath |
	entries _ super directoryContentsFor: fullPath.
	fullPath isNullPath
		ifTrue: [
			"For Acorn we also make sure that at least the parent of the current dir 
			is added - sometimes this is in a filing system that has not been (or 
			cannot be) polled for disc root names"
			extraPath _ self class default containingDirectory.
			"Only add the extra path if we haven't already got the root of the current dir in the list"
			entries detect: [:ent | extraPath fullName beginsWith: ent name] 
				ifNone: [entries _ entries
								copyWith: (DirectoryEntry
										name: extraPath fullName
										creationTime: 0
										modificationTime: 0
										isDirectory: true
										fileSize: 0)]].
	^ entries
! !


!AcornFileDirectory methodsFor: 'testing' stamp: 'tpr 4/28/2004 21:54'!
directoryExists: filenameOrPath
"if the path is a root,we have to treat it carefully"
	(filenameOrPath endsWith: '$') ifTrue:[^(FileDirectory on: filenameOrPath) exists].
	^(self directoryNamed: filenameOrPath ) exists! !


!AcornFileDirectory methodsFor: 'path access' stamp: 'tpr 11/30/2003 21:42'!
pathParts
	"Return the path from the root of the file system to this directory as an 
	array of directory names.
	This version tries to cope with the RISC OS' strange filename formatting; 
	filesystem::discname/$/path/to/file
	where the $ needs to be considered part of the filingsystem-discname atom."
	| pathList |
	pathList := super pathParts.
	(pathList indexOf: '$') = 2
		ifTrue: ["if the second atom is root ($) then stick $ on the first atom 
				and drop the second. Yuck"
			^ Array
				streamContents: [:a | 
					a nextPut: (pathList at: 1), '/$'.
					3 to: pathList size do: [:i | a
								nextPut: (pathList at: i)]]].
	^ pathList! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AcornFileDirectory class
	instanceVariableNames: ''!

!AcornFileDirectory class methodsFor: 'platform specific' stamp: 'md 10/26/2003 13:16'!
isActiveDirectoryClass
	"Does this class claim to be that properly active subclass of FileDirectory  
	for the current platform? On Acorn, the test is whether platformName 
	is 'RiscOS' (on newer VMs) or if the primPathNameDelimiter is $. (on
	older ones), which is what we would like to use for a dirsep if only it
	would work out. See pathNameDelimiter for more woeful details - then
	just get on and enjoy Squeak"

	^ SmalltalkImage current platformName = 'RiscOS'
		or: [self primPathNameDelimiter = $.]! !

!AcornFileDirectory class methodsFor: 'platform specific' stamp: 'tpr 8/1/2003 16:38'!
isCaseSensitive
	"Risc OS ignores the case of file names"
	^ false! !

!AcornFileDirectory class methodsFor: 'platform specific' stamp: 'TPR 7/20/1999 17:52'!
maxFileNameLength

	^ 255
! !

!AcornFileDirectory class methodsFor: 'platform specific' stamp: 'TPR 5/10/1998 21:45'!
pathNameDelimiter
"Acorn RiscOS uses a dot as the directory separator and has no real concept of filename extensions. We tried to make code handle this, but there are just too many uses of dot as a filename extension - so fake it out by pretending to use a slash. The file prims do conversions instead.
Sad, but pragmatic"
	^ $/
! !


!AcornFileDirectory class methodsFor: 'class initialization' stamp: 'tpr 12/23/2004 19:20'!
initialize
"Set up the legal chars map for filenames. May need extending for unicode etc.
Basic rule is that any char legal for use in filenames will have a non-nil entry in this array; except for space, this is the same character. Space is transcoded to a char 160 to be a 'hard space' "
"AcornFileDirectory initialize"
	| aVal |
	LegalCharMap _ Array new: 256.
	Character alphabet do:[:c|
		LegalCharMap at: c asciiValue +1  put: c.
		LegalCharMap at: (aVal _ c asUppercase) asciiValue +1 put: aVal].
	'`!!()-_=+[{]};~,./1234567890' do:[:c|
			LegalCharMap at: c asciiValue + 1 put: c].
	LegalCharMap at: Character space asciiValue +1 put: (Character value:160 "hardspace").
	LegalCharMap at: 161 put: (Character value:160 "hardspace")."secondary mapping to keep it in strings"! !
Array variableSubclass: #ActionSequence
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Object Events'!

!ActionSequence methodsFor: 'converting' stamp: 'reThink 2/18/2001 15:12'!
asActionSequence

	^self! !

!ActionSequence methodsFor: 'converting' stamp: 'rw 7/20/2003 16:03'!
asActionSequenceTrappingErrors

	^WeakActionSequenceTrappingErrors withAll: self! !

!ActionSequence methodsFor: 'converting' stamp: 'reThink 2/18/2001 15:28'!
asMinimalRepresentation

	self size = 0
		ifTrue: [^nil].
	self size = 1
		ifTrue: [^self first].
	^self! !


!ActionSequence methodsFor: 'evaluating' stamp: 'reThink 2/18/2001 17:51'!
value
    "Answer the result of evaluating the elements of the receiver."

    | answer |
    self do:
        [:each |
        answer := each value].
    ^answer! !

!ActionSequence methodsFor: 'evaluating' stamp: 'reThink 2/18/2001 17:52'!
valueWithArguments: anArray

    | answer |
    self do:
        [:each |
        answer := each valueWithArguments: anArray].
    ^answer! !


!ActionSequence methodsFor: 'printing' stamp: 'SqR 07/28/2001 18:25'!
printOn: aStream

	self size < 2 ifTrue: [^super printOn: aStream].
	aStream nextPutAll: '#('.
	self
		do: [:each | each printOn: aStream]
		separatedBy: [aStream cr].
	aStream nextPut: $)! !
Object subclass: #ActorState
	instanceVariableNames: 'owningPlayer penDown penSize penColor fractionalPosition instantiatedUserScriptsDictionary penArrowheads trailStyle'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Support'!
!ActorState commentStamp: '<historical>' prior: 0!
Holds a record of data representing actor-like slots in the Morph, on behalf of an associated Player.  Presently also holds onto the scriptInstantion objects that represent active scripts in an instance, but this will probably change soon.!


!ActorState methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 21:53'!
printOnStream: aStream
	aStream print: 'ActorState for '; print:owningPlayer externalName; print:' '.
	penDown ifNotNil: [aStream cr; print: 'penDown '; write:penDown].
	penColor ifNotNil: [aStream cr; print: 'penColor '; write:penColor].
	penSize ifNotNil: [aStream cr; print: 'penSize '; write:penSize].
	instantiatedUserScriptsDictionary ifNotNil:
		[aStream cr; print:
			'+ '; write: instantiatedUserScriptsDictionary size; print:' user scripts'].
! !


!ActorState methodsFor: 'initialization' stamp: 'sw 5/13/1998 16:37'!
initializeFor: aPlayer
	| aNewDictionary |
	owningPlayer _ aPlayer.
	instantiatedUserScriptsDictionary ifNil: [^ self].
	aNewDictionary _ IdentityDictionary new.
	instantiatedUserScriptsDictionary associationsDo: 
		[:assoc |
			aNewDictionary at: assoc key put: (assoc value shallowCopy player: aPlayer)].
	instantiatedUserScriptsDictionary _ aNewDictionary.! !


!ActorState methodsFor: 'other' stamp: 'sw 4/22/1998 17:02'!
addPlayerMenuItemsTo: aMenu hand: aHandMorph
	self getPenDown
		ifTrue: [aMenu add: 'pen up' action: #liftPen]
		ifFalse: [aMenu add: 'pen down' action: #lowerPen].
	aMenu add: 'pen size' action: #choosePenSize.
	aMenu add: 'pen color' action: #choosePenColor:.! !

!ActorState methodsFor: 'other' stamp: 'sw 4/13/1998 19:36'!
costume
	^ owningPlayer costume! !


!ActorState methodsFor: 'pen' stamp: 'nk 6/12/2004 16:36'!
choosePenColor: evt
	owningPlayer costume changeColorTarget: owningPlayer costume selector: #penColor: originalColor: owningPlayer getPenColor hand: evt hand.! !

!ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:44'!
choosePenSize
	| menu sz |
	menu _ CustomMenu new.
	1 to: 10 do: [:w | menu add: w printString action: w].
	sz _ menu startUp.
	sz ifNotNil: [penSize _ sz]! !

!ActorState methodsFor: 'pen' stamp: 'sw 2/4/98 15:16'!
defaultPenColor
	^ Color blue! !

!ActorState methodsFor: 'pen' stamp: 'sw 2/4/98 15:03'!
defaultPenSize
	^ 1! !

!ActorState methodsFor: 'pen' stamp: 'tk 10/4/2001 16:42'!
getPenArrowheads
	^ penArrowheads == true! !

!ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:35'!
getPenColor
	penColor ifNil: [penColor _ self defaultPenColor].
	^ penColor! !

!ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:40'!
getPenDown
	^ penDown == true! !

!ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:43'!
getPenSize
	penSize ifNil: [penSize _ self defaultPenSize].
	^ penSize! !

!ActorState methodsFor: 'pen' stamp: 'sw 2/4/98 18:07'!
liftPen
	penDown _ false! !

!ActorState methodsFor: 'pen' stamp: 'sw 2/4/98 14:58'!
lowerPen
	penDown _ true! !

!ActorState methodsFor: 'pen' stamp: 'sw 2/4/98 18:03'!
penColor: aColor
	penColor _ aColor! !

!ActorState methodsFor: 'pen' stamp: 'tk 10/4/2001 16:43'!
setPenArrowheads: aBoolean
	penArrowheads _ aBoolean! !

!ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:51'!
setPenColor: aColor
	penColor _ aColor
! !

!ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:47'!
setPenDown: aBoolean
	penDown _ aBoolean! !

!ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:45'!
setPenSize: aNumber
	penSize _ aNumber! !

!ActorState methodsFor: 'pen' stamp: 'sw 4/16/2003 12:26'!
trailStyle
	"Answer the receiver's trailStyle.  For backward compatibility, if the old penArrowheads slot is in found to be set, use it as a guide for initialization"

	^ trailStyle ifNil: [trailStyle _ penArrowheads == true ifTrue: [#arrows] ifFalse: [#lines]]! !

!ActorState methodsFor: 'pen' stamp: 'sw 3/11/2003 11:28'!
trailStyle: aSymbol
	"Set the trail style to the given symbol"

	trailStyle _ aSymbol! !


!ActorState methodsFor: 'position' stamp: 'jm 4/24/1998 21:34'!
fractionalPosition
	"Return my player's costume's position including the fractional part. This allows the precise position to be retained to avoid cummulative rounding errors, while letting Morphic do all its calculations with integer pixel coordinates. See the implementation of forward:."

	^ fractionalPosition
! !

!ActorState methodsFor: 'position' stamp: 'jm 4/24/1998 21:31'!
fractionalPosition: aPoint

	fractionalPosition _ aPoint asFloatPoint.
! !


!ActorState methodsFor: 'printing' stamp: 'sw 5/12/1998 23:35'!
printOn: aStream
	aStream nextPutAll: 'ActorState for ', owningPlayer externalName, ' '.
	penDown ifNotNil: [aStream cr; nextPutAll: 'penDown ', penDown printString].
	penColor ifNotNil: [aStream cr; nextPutAll: 'penColor ', penColor printString].
	penSize ifNotNil: [aStream cr; nextPutAll: 'penSize ', penSize printString].
	instantiatedUserScriptsDictionary ifNotNil:
		[aStream cr; nextPutAll:
			'+ ', instantiatedUserScriptsDictionary size printString, ' user scripts'].
! !


!ActorState methodsFor: 'script instantiations' stamp: 'sw 4/9/98 22:35'!
instantiatedUserScriptsDictionary
	instantiatedUserScriptsDictionary ifNil: [instantiatedUserScriptsDictionary _ IdentityDictionary new].
	^ instantiatedUserScriptsDictionary! !
SoundCodec subclass: #ADPCMCodec
	instanceVariableNames: 'predicted index deltaSignMask deltaValueMask deltaValueHighBit frameSizeMask currentByte bitPosition byteIndex encodedBytes samples rightSamples sampleIndex bitsPerSample stepSizeTable indexTable'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!ADPCMCodec commentStamp: '<historical>' prior: 0!
This is a simple ADPCM (adapative delta pulse code modulation) codec. This is a general audio codec that compresses speech, music, or sound effects equally well, and works at any sampling rate (i.e., it contains no frequency-sensitive filters). It compresses 16-bit sample data down to 5, 4, 3, or 2 bits per sample, with lower fidelity and increased noise at the lowest bit rates. Although it does not deliver state-of-the-art compressions, the algorithm is small, simple, and extremely fast, since the encode/decode primitives have been translated into C primitives.

This codec will also encode and decode all Flash .swf file compressed sound formats, both mono and stereo. (Note: stereo Flash compression is not yet implemented, but stereo decompression works.)
!


!ADPCMCodec methodsFor: 'bit streaming' stamp: 'jm 3/28/1999 16:24'!
nextBits: n
	"Answer the next n bits of my bit stream as an unsigned integer."

	| result remaining shift |
	self inline: true.

	result _ 0.
	remaining _ n.
	[true] whileTrue: [
		shift _ remaining - bitPosition.
		result _ result + (currentByte bitShift: shift).
		shift > 0
			ifTrue: [  "consumed currentByte buffer; fetch next byte"
				remaining _ remaining - bitPosition.			
				currentByte _ (encodedBytes at: (byteIndex _ byteIndex + 1)).
				bitPosition _ 8]
			ifFalse: [  "still some bits left in currentByte buffer"
				bitPosition _ bitPosition - remaining.
				"mask out the consumed bits:"
				currentByte _ currentByte bitAnd: (255 bitShift: (bitPosition - 8)).
				^ result]].
! !

!ADPCMCodec methodsFor: 'bit streaming' stamp: 'jm 3/28/1999 20:21'!
nextBits: n put: anInteger
	"Write the next n bits to my bit stream."

	| buf bufBits bitsAvailable shift |
	self inline: true.

	buf _ anInteger.
	bufBits _ n.
	[true] whileTrue: [
		bitsAvailable _ 8 - bitPosition.
		shift _ bitsAvailable - bufBits.  "either left or right shift"
		"append high bits of buf to end of currentByte:"
		currentByte _ currentByte + (buf bitShift: shift).
		shift < 0
			ifTrue: [  "currentByte buffer filled; output it"
				encodedBytes at: (byteIndex _ byteIndex + 1) put: currentByte.
				bitPosition _ 0.
				currentByte _ 0.
				"clear saved high bits of buf:"
				buf _ buf bitAnd: (1 bitShift: 0 - shift) - 1.
				bufBits _ bufBits - bitsAvailable]
			ifFalse: [  "still some bits available in currentByte buffer"
				bitPosition _ bitPosition + bufBits.
				^ self]].
! !


!ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 12/12/2001 17:57'!
bytesPerEncodedFrame
	"Answer the number of bytes required to hold one frame of compressed sound data."
	"Note: When used as a normal codec, the frame size is always 8 samples which results in (8 * bitsPerSample) / 8 = bitsPerSample bytes."

	| bitCount |
	frameSizeMask = 0 ifTrue: [^ bitsPerSample].
	"Following assumes mono:"
	bitCount _ 16 + 6 + ((self samplesPerFrame - 1) * bitsPerSample).
	^ (bitCount + 7) // 8
! !

!ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 7/2/1999 13:29'!
compressAndDecompress: aSound
	"Compress and decompress the given sound. Overridden to use same bits per sample for both compressing and decompressing."

	| compressed decoder |
	compressed _ self compressSound: aSound.
	decoder _ self class new
		initializeForBitsPerSample: bitsPerSample
		samplesPerFrame: 0.
	^ decoder decompressSound: compressed

! !

!ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 3/28/1999 15:37'!
decodeFrames: frameCount from: srcByteArray at: srcIndex into: dstSoundBuffer at: dstIndex
	"Decode the given number of monophonic frames starting at the given index in the given ByteArray of compressed sound data and storing the decoded samples into the given SoundBuffer starting at the given destination index. Answer a pair containing the number of bytes of compressed data consumed and the number of decompressed samples produced."
	"Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers."

	encodedBytes _ srcByteArray.
	byteIndex _ srcIndex - 1.
	bitPosition _ 0.
	currentByte _ 0.
	samples _ dstSoundBuffer.
	sampleIndex _ dstIndex - 1.
	self privateDecodeMono: (frameCount * self samplesPerFrame).
	^ Array with: (byteIndex - (srcIndex - 1)) with: (sampleIndex - (dstIndex - 1))
! !

!ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 3/28/1999 15:28'!
encodeFrames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex
	"Encode the given number of frames starting at the given index in the given monophonic SoundBuffer and storing the encoded sound data into the given ByteArray starting at the given destination index. Encode only as many complete frames as will fit into the destination. Answer a pair containing the number of samples consumed and the number of bytes of compressed data produced."
	"Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers."

	samples _ srcSoundBuffer.
	sampleIndex _ srcIndex - 1.
	encodedBytes _ dstByteArray.
	byteIndex _ dstIndex - 1.
	bitPosition _ 0.
	currentByte _ 0.
	self privateEncodeMono: (frameCount * self samplesPerFrame).
	^ Array with: frameCount with: (byteIndex - (dstIndex - 1))
! !

!ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 12/14/2001 11:21'!
reset

	self resetForMono.
! !

!ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 3/28/1999 20:12'!
resetForMono
	"Reset my encoding and decoding state for mono."

	predicted _ 0.
	index _ 0.
! !

!ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 3/28/1999 20:12'!
resetForStereo
	"Reset my encoding and decoding state for stereo."

	"keep state as SoundBuffers to allow fast access from primitive"
	predicted _ SoundBuffer new: 2.
	index _ SoundBuffer new: 2.
! !

!ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 3/27/1999 08:34'!
samplesPerFrame
	"Answer the number of sound samples per compression frame."

	frameSizeMask > 0 ifTrue: [^ frameSizeMask + 1].
	^ 8  "frame size when there are no running headers"
! !


!ADPCMCodec methodsFor: 'private' stamp: 'jm 3/28/1999 06:26'!
decode: aByteArray bitsPerSample: bits

	^ self
		decode: aByteArray
		sampleCount: (aByteArray size * 8) // bits
		bitsPerSample: bits
		frameSize: 0
		stereo: false
! !

!ADPCMCodec methodsFor: 'private' stamp: 'jm 3/28/1999 15:57'!
decode: aByteArray sampleCount: count bitsPerSample: bits frameSize: frameSize stereo: stereoFlag

	self initializeForBitsPerSample: bits samplesPerFrame: frameSize.
	encodedBytes _ aByteArray.
	byteIndex _ 0.
	bitPosition _ 0.
	currentByte _ 0.
	stereoFlag
		ifTrue: [
			self resetForStereo.
			samples _ SoundBuffer newMonoSampleCount: count.
			rightSamples _ SoundBuffer newMonoSampleCount: count.
			sampleIndex _ 0.
			self privateDecodeStereo: count.
			^ Array with: samples with: rightSamples]
		ifFalse: [
			samples _ SoundBuffer newMonoSampleCount: count.
			sampleIndex _ 0.
			self privateDecodeMono: count.
			^ samples]
! !

!ADPCMCodec methodsFor: 'private' stamp: 'jm 3/30/1999 08:56'!
decodeFlash: aByteArray sampleCount: sampleCount stereo: stereoFlag

	| bits |
	encodedBytes _ aByteArray.
	byteIndex _ 0.
	bitPosition _ 0.
	currentByte _ 0.
	bits _ 2 + (self nextBits: 2).  "bits per sample"
	self initializeForBitsPerSample: bits samplesPerFrame: 4096.
	stereoFlag
		ifTrue: [
			self resetForStereo.
			samples _ SoundBuffer newMonoSampleCount: sampleCount.
			rightSamples _ SoundBuffer newMonoSampleCount: sampleCount.
			sampleIndex _ 0.
			self privateDecodeStereo: sampleCount.
			^ Array with: samples with: rightSamples]
		ifFalse: [
			samples _ SoundBuffer newMonoSampleCount: sampleCount.
			sampleIndex _ 0.
			self privateDecodeMono: sampleCount.
			^ Array with: samples].
! !

!ADPCMCodec methodsFor: 'private' stamp: 'jm 3/28/1999 08:59'!
encode: aSoundBuffer bitsPerSample: bits

	^ self
		encodeLeft: aSoundBuffer
		right: nil
		bitsPerSample: bits
		frameSize: 0
		forFlash: false
! !

!ADPCMCodec methodsFor: 'private' stamp: 'jm 3/28/1999 08:58'!
encodeFlashLeft: leftSoundBuffer right: rightSoundBuffer bitsPerSample: bits

	^ self
		encodeLeft: leftSoundBuffer
		right: rightSoundBuffer
		bitsPerSample: bits
		frameSize: 4096
		forFlash: true
! !

!ADPCMCodec methodsFor: 'private' stamp: 'jm 11/21/2001 11:35'!
encodeLeft: leftSoundBuffer right: rightSoundBuffer bitsPerSample: bits frameSize: frameSize forFlash: flashFlag

	| stereoFlag sampleCount sampleBitCount bitCount |
	self initializeForBitsPerSample: bits samplesPerFrame: frameSize.
	stereoFlag _ rightSoundBuffer notNil.
	sampleCount _ leftSoundBuffer monoSampleCount.
	stereoFlag
		ifTrue: [sampleBitCount _ 2 * (sampleCount * bitsPerSample)]
		ifFalse: [sampleBitCount _ sampleCount * bitsPerSample].
	bitCount _ sampleBitCount +
		(self headerBitsForSampleCount: sampleCount stereoFlag: stereoFlag).

	encodedBytes _ ByteArray new: ((bitCount / 8) ceiling roundUpTo: self bytesPerEncodedFrame).
	byteIndex _ 0.
	bitPosition _ 0.
	currentByte _ 0.
	flashFlag ifTrue: [self nextBits: 2 put: bits - 2].
	stereoFlag
		ifTrue: [
			samples _ Array with: leftSoundBuffer with: rightSoundBuffer.
			sampleIndex _ Array with: 0 with: 0.
			self privateEncodeStereo: sampleCount]
		ifFalse: [
			samples _ leftSoundBuffer.
			sampleIndex _ 0.
			self privateEncodeMono: sampleCount].

	^ encodedBytes
! !

!ADPCMCodec methodsFor: 'private' stamp: 'jm 3/27/1999 12:14'!
headerBitsForSampleCount: sampleCount stereoFlag: stereoFlag
	"Answer the number of extra header bits required for the given number of samples. This will be zero if I am not using frame headers."

	| frameCount bitsPerHeader |
	frameSizeMask = 0 ifTrue: [^ 0].
	frameCount _ (sampleCount / self samplesPerFrame) ceiling.
	bitsPerHeader _ 16 + 6.
	stereoFlag ifTrue: [bitsPerHeader _ 2 * bitsPerHeader].
	^ frameCount * bitsPerHeader
! !

!ADPCMCodec methodsFor: 'private' stamp: 'zz 3/2/2004 07:58'!
indexForDeltaFrom: thisSample to: nextSample
	"Answer the best index to use for the difference between the given samples."
	"Details: Scan stepSizeTable for the first entry >= the absolute value of the difference between sample values. Since indexes are zero-based, the index used during decoding will be the one in the following stepSizeTable entry. Since the index field of a Flash frame header is only six bits, the maximum index value is 63."
	"Note: Since there does not appear to be any documentation of how Flash actually computes the indices used in its frame headers, this algorithm was guessed by reverse-engineering the Flash ADPCM decoder."

	| diff bestIndex |
	self inline: true.

	diff _ nextSample - thisSample.
	diff < 0 ifTrue: [diff _ 0 - diff].
	bestIndex _ 63.
	1 to: 62 do: [:j |
		bestIndex = 63 ifTrue: [
			(stepSizeTable at: j) >= diff ifTrue: [bestIndex _ j]]].
	^ bestIndex
! !

!ADPCMCodec methodsFor: 'private' stamp: 'jm 3/28/1999 20:48'!
initializeForBitsPerSample: sampleBits samplesPerFrame: frameSize

	self resetForMono.
	stepSizeTable _ #(7 8 9 10 11 12 13 14 16 17 19 21 23 25 28 31 34 37 41 45 50 55 60 66 73 80 88 97 107 118 130 143 157 173 190 209 230 253 279 307 337 371 408 449 494 544 598 658 724 796 876 963 1060 1166 1282 1411 1552 1707 1878 2066 2272 2499 2749 3024 3327 3660 4026 4428 4871 5358 5894 6484 7132 7845 8630 9493 10442 11487 12635 13899 15289 16818 18500 20350 22385 24623 27086 29794 32767).

	indexTable _ nil.
	sampleBits = 2 ifTrue: [
		indexTable _ #(-1 2)].
	sampleBits = 3 ifTrue: [
		indexTable _ #(-1 -1 2 4)].
	sampleBits = 4 ifTrue: [
		indexTable _ #(-1 -1 -1 -1 2 4 6 8)].
	sampleBits = 5 ifTrue: [
		indexTable _ #(-1 -1 -1 -1 -1 -1 -1 -1 1 2 4 6 8 10 13 16)].
	indexTable ifNil: [self error: 'unimplemented bits/sample'].

	bitsPerSample _ sampleBits.
	deltaSignMask _ 1 bitShift: bitsPerSample - 1.
	deltaValueMask _ deltaSignMask - 1.
	deltaValueHighBit _ deltaSignMask / 2.

	frameSize <= 1
		ifTrue: [frameSizeMask _ 0]
		ifFalse: [
			(frameSize = (1 bitShift: frameSize highBit - 1))
				ifFalse: [self error: 'frameSize must be a power of two'].
			frameSizeMask _ frameSize - 1].

	"keep as SoundBuffer to allow fast access from primitive"
	indexTable _ SoundBuffer fromArray: indexTable.
	stepSizeTable _ SoundBuffer fromArray: stepSizeTable.
! !

!ADPCMCodec methodsFor: 'private' stamp: 'ar 4/23/2001 15:11'!
privateDecodeMono: count

	| delta step predictedDelta bit |
	<primitive: 'primitiveDecodeMono' module: 'ADPCMCodecPlugin'>
	self var: #stepSizeTable declareC: 'short int *stepSizeTable'.
	self var: #indexTable declareC: 'short int *indexTable'.
	self var: #samples declareC: 'short int *samples'.
	self var: #encodedBytes declareC: 'unsigned char *encodedBytes'.

	1 to: count do: [:i |
		(i bitAnd: frameSizeMask) = 1
			ifTrue: [  "start of frame; read frame header"
				predicted _ self nextBits: 16.
				predicted > 32767 ifTrue: [predicted _ predicted - 65536].
				index _ self nextBits: 6.
				samples at: (sampleIndex _ sampleIndex + 1) put: predicted]
			ifFalse: [
				delta _ self nextBits: bitsPerSample.
				step _ stepSizeTable at: index + 1.
				predictedDelta _ 0.
				bit _ deltaValueHighBit.
				[bit > 0] whileTrue: [
					(delta bitAnd: bit) > 0 ifTrue: [predictedDelta _ predictedDelta + step].
					step _ step bitShift: -1.
					bit _ bit bitShift: -1].
				predictedDelta _ predictedDelta + step.

				(delta bitAnd: deltaSignMask) > 0
					ifTrue: [predicted _ predicted - predictedDelta]
					ifFalse: [predicted _ predicted + predictedDelta].
				predicted > 32767
					ifTrue: [predicted _ 32767]
					ifFalse: [predicted < -32768 ifTrue: [predicted _ -32768]].

				index _ index + (indexTable at: (delta bitAnd: deltaValueMask) + 1).
				index < 0
					ifTrue: [index _ 0]
					ifFalse: [index > 88 ifTrue: [index _ 88]].

				samples at: (sampleIndex _ sampleIndex + 1) put: predicted]].
! !

!ADPCMCodec methodsFor: 'private' stamp: 'ar 4/23/2001 15:11'!
privateDecodeStereo: count

	| predictedLeft predictedRight indexLeft indexRight deltaLeft deltaRight
	 stepLeft stepRight predictedDeltaLeft predictedDeltaRight bit |

	<primitive: 'primitiveDecodeStereo' module: 'ADPCMCodecPlugin'>
	self var: #stepSizeTable declareC: 'short int *stepSizeTable'.
	self var: #indexTable declareC: 'short int *indexTable'.
	self var: #samples declareC: 'short int *samples'.
	self var: #encodedBytes declareC: 'unsigned char *encodedBytes'.
	self var: #rightSamples declareC: 'short int *rightSamples'.
	self var: #predicted declareC: 'short int *predicted'.
	self var: #index declareC: 'short int *index'.

	"make local copies of decoder state variables"
	predictedLeft _ predicted at: 1.
	predictedRight _ predicted at: 2.
	indexLeft _ index at: 1.
	indexRight _ index at: 2.

	1 to: count do: [:i |
		(i bitAnd: frameSizeMask) = 1
			ifTrue: [  "start of frame; read frame header"
				predictedLeft _ self nextBits: 16.
				indexLeft _ self nextBits: 6.
				predictedRight _ self nextBits: 16.
				indexRight _ self nextBits: 6.
				predictedLeft > 32767 ifTrue: [predictedLeft _ predictedLeft - 65536].
				predictedRight > 32767 ifTrue: [predictedRight _ predictedRight - 65536].
				samples at: (sampleIndex _ sampleIndex + 1) put: predictedLeft.
				rightSamples at: sampleIndex put: predictedRight]
			ifFalse: [
				deltaLeft _ self nextBits: bitsPerSample.
				deltaRight _ self nextBits: bitsPerSample.
				stepLeft _ stepSizeTable at: indexLeft + 1.
				stepRight _ stepSizeTable at: indexRight + 1.
				predictedDeltaLeft _ predictedDeltaRight _ 0.
				bit _ deltaValueHighBit.
				[bit > 0] whileTrue: [
					(deltaLeft bitAnd: bit) > 0 ifTrue: [
						predictedDeltaLeft _ predictedDeltaLeft + stepLeft].
					(deltaRight bitAnd: bit) > 0 ifTrue: [
						predictedDeltaRight _ predictedDeltaRight + stepRight].
					stepLeft _ stepLeft bitShift: -1.
					stepRight _ stepRight bitShift: -1.
					bit _ bit bitShift: -1].
				predictedDeltaLeft _ predictedDeltaLeft + stepLeft.
				predictedDeltaRight _ predictedDeltaRight + stepRight.

				(deltaLeft bitAnd: deltaSignMask) > 0
					ifTrue: [predictedLeft _ predictedLeft - predictedDeltaLeft]
					ifFalse: [predictedLeft _ predictedLeft + predictedDeltaLeft].
				(deltaRight bitAnd: deltaSignMask) > 0
					ifTrue: [predictedRight _ predictedRight - predictedDeltaRight]
					ifFalse: [predictedRight _ predictedRight + predictedDeltaRight].
				predictedLeft > 32767
					ifTrue: [predictedLeft _ 32767]
					ifFalse: [predictedLeft < -32768 ifTrue: [predictedLeft _ -32768]].
				predictedRight > 32767
					ifTrue: [predictedRight _ 32767]
					ifFalse: [predictedRight < -32768 ifTrue: [predictedRight _ -32768]].

				indexLeft _ indexLeft + (indexTable at: (deltaLeft bitAnd: deltaValueMask) + 1).
				indexLeft < 0
					ifTrue: [indexLeft _ 0]
					ifFalse: [indexLeft > 88 ifTrue: [indexLeft _ 88]].
				indexRight _ indexRight + (indexTable at: (deltaRight bitAnd: deltaValueMask) + 1).
				indexRight < 0
					ifTrue: [indexRight _ 0]
					ifFalse: [indexRight > 88 ifTrue: [indexRight _ 88]].

				samples at: (sampleIndex _ sampleIndex + 1) put: predictedLeft.
				rightSamples at: sampleIndex put: predictedRight]].

	"save local copies of decoder state variables"
	predicted at: 1 put: predictedLeft.
	predicted at: 2 put: predictedRight.
	index at: 1 put: indexLeft.
	index at: 2 put: indexRight.
! !

!ADPCMCodec methodsFor: 'private' stamp: 'ar 4/23/2001 15:11'!
privateEncodeMono: count

	| step sign diff delta predictedDelta bit p |
	<primitive: 'primitiveEncodeMono' module: 'ADPCMCodecPlugin'>
	self var: #stepSizeTable declareC: 'short int *stepSizeTable'.
	self var: #indexTable declareC: 'short int *indexTable'.
	self var: #samples declareC: 'short int *samples'.
	self var: #encodedBytes declareC: 'unsigned char *encodedBytes'.

	step _ stepSizeTable at: 1.
	1 to: count do: [:i |
		(i bitAnd: frameSizeMask) = 1 ifTrue: [
			predicted _ samples at: (sampleIndex _ sampleIndex + 1).
			(p _ predicted) < 0 ifTrue: [p _ p + 65536].
			self nextBits: 16 put: p.
			i < count ifTrue: [
				index _ self indexForDeltaFrom: predicted to: (samples at: sampleIndex + 1)].
			self nextBits: 6 put: index.
		] ifFalse: [
			"compute sign and magnitude of difference from the predicted sample"
			sign _ 0.
			diff _ (samples at: (sampleIndex _ sampleIndex + 1)) - predicted.
			diff < 0 ifTrue: [
				sign _ deltaSignMask.
				diff _ 0 - diff].

			"Compute encoded delta and the difference that this will cause in the predicted sample value during decoding. Note that this code approximates:
				delta _ (4 * diff) / step.
				predictedDelta _ ((delta + 0.5) * step) / 4;
			but in the shift step bits are dropped. Thus, even if you have fast mul/div hardware you cannot use it since you would get slightly different bits what than the algorithm defines."
			delta _ 0.
			predictedDelta _ 0.
			bit _ deltaValueHighBit.
			[bit > 0] whileTrue: [
				diff >= step ifTrue: [
					delta _ delta + bit.
					predictedDelta _ predictedDelta + step.
					diff _ diff - step].
				step _ step bitShift: -1.
				bit _ bit bitShift: -1].
			predictedDelta _ predictedDelta + step.

			"compute and clamp new prediction"
			sign > 0
				ifTrue: [predicted _ predicted - predictedDelta]
				ifFalse: [predicted _ predicted + predictedDelta].
			predicted > 32767
				ifTrue: [predicted _ 32767]
				ifFalse: [predicted < -32768 ifTrue: [predicted _ -32768]].

			"compute new index and step values"
			index _ index + (indexTable at: delta + 1).
			index < 0
				ifTrue: [index _ 0]
				ifFalse: [index > 88 ifTrue: [index _ 88]].
			step _ stepSizeTable at: index + 1.

			"output encoded, signed delta"
			self nextBits: bitsPerSample put: (sign bitOr: delta)]].

	bitPosition > 0 ifTrue: [  "flush the last output byte, if necessary"
		encodedBytes at: (byteIndex _ byteIndex + 1) put: currentByte].
! !

!ADPCMCodec methodsFor: 'private' stamp: 'ar 4/23/2001 15:12'!
privateEncodeStereo: count

	<primitive: 'primitiveEncodeStereo' module: 'ADPCMCodecPlugin'>
	"not yet implemented"
	self inline: false.
	self success: false.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ADPCMCodec class
	instanceVariableNames: ''!

!ADPCMCodec class methodsFor: 'instance creation' stamp: 'jm 3/27/1999 11:15'!
new

	^ super new
		initializeForBitsPerSample: 4
		samplesPerFrame: 0.
! !

!ADPCMCodec class methodsFor: 'instance creation' stamp: 'jm 11/15/2001 16:02'!
newBitsPerSample: bitsPerSample

	^ super new
		initializeForBitsPerSample: bitsPerSample
		samplesPerFrame: 0.
! !


!ADPCMCodec class methodsFor: 'primitive generation' stamp: 'ar 2/3/2001 15:50'!
translatedPrimitives
	"Answer a string containing the translated C code for my primitives."
	"Note: This code currently must be hand-edited to remove several methods that are inlined (thus not needed) but not pruned out by the ST-to-C translator."

	^#(
		(ADPCMCodec privateDecodeMono:)
		(ADPCMCodec privateDecodeStereo:)
		(ADPCMCodec privateEncodeMono:)
		(ADPCMCodec privateEncodeStereo:)
		(ADPCMCodec indexForDeltaFrom:to:)
		(ADPCMCodec nextBits:)
		(ADPCMCodec nextBits:put:))
! !
AbstractEvent subclass: #AddedEvent
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Change Notification'!

!AddedEvent methodsFor: 'testing' stamp: 'rw 6/30/2003 08:35'!
isAdded

	^true! !


!AddedEvent methodsFor: 'printing' stamp: 'rw 6/30/2003 09:31'!
printEventKindOn: aStream

	aStream nextPutAll: 'Added'! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AddedEvent class
	instanceVariableNames: ''!

!AddedEvent class methodsFor: 'accessing' stamp: 'rw 7/19/2003 09:52'!
changeKind

	^#Added! !

!AddedEvent class methodsFor: 'accessing' stamp: 'NS 1/20/2004 12:22'!
supportedKinds
	"All the kinds of items that this event can take."
	
	^ Array with: self classKind with: self methodKind with: self categoryKind with: self protocolKind! !
Object subclass: #AIFFFileReader
	instanceVariableNames: 'in fileType channelCount frameCount bitsPerSample samplingRate channelData channelDataOffset markers pitch gain isLooped skipDataChunk mergeIfStereo'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!AIFFFileReader commentStamp: '<historical>' prior: 0!
I am a parser for AIFF (audio interchange file format) files. I can read uncompressed 8-bit and 16-bit mono, stereo, or multichannel AIFF files. I read the marker information used by the TransferStation utility to mark the loop points in sounds extracted from commercial sampled-sound CD-ROMs.
!


!AIFFFileReader methodsFor: 'reading' stamp: 'jm 8/2/1998 16:27'!
readFromFile: fileName
	"Read the AIFF file of the given name."
	"AIFFFileReader new readFromFile: 'test.aiff'"

	self readFromFile: fileName
		mergeIfStereo: false
		skipDataChunk: false.
! !

!AIFFFileReader methodsFor: 'reading' stamp: 'jm 10/17/2001 17:20'!
readFromFile: fileName mergeIfStereo: mergeFlag skipDataChunk: skipDataFlag
	"Read the AIFF file of the given name. See comment in readFromStream:mergeIfStereo:skipDataChunk:."
	"AIFFFileReader new readFromFile: 'test.aiff' mergeIfStereo: false skipDataChunk: true"

	| f |
	f _ (FileStream readOnlyFileNamed: fileName) binary.
	self readFromStream: f mergeIfStereo: mergeFlag skipDataChunk: skipDataFlag.
	f close.
! !

!AIFFFileReader methodsFor: 'reading'!
readFromStream: aBinaryStream mergeIfStereo: mergeFlag skipDataChunk: skipDataFlag
	"Read an AIFF file from the given binary stream. If mergeFlag is true and the file contains stereo data, then the left and right channels will be mixed together as the samples are read in. If skipDataFlag is true, then the data chunk to be skipped; this allows the other chunks of a file to be processed in order to extract format information quickly without reading the data."

	mergeIfStereo _ mergeFlag.
	skipDataChunk _ skipDataFlag.
	isLooped _ false.
	gain _ 1.0.
	self readFrom: aBinaryStream.
! !


!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 21:25'!
bitsPerSample

	^ bitsPerSample
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 21:24'!
channelCount

	^ channelCount
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 21:25'!
channelData

	^ channelData
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 10/20/2001 15:07'!
channelDataOffset

	^ channelDataOffset
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 21:24'!
frameCount

	^ frameCount
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 21:25'!
gain

	^ gain
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 7/12/1998 01:40'!
isLooped

	^ isLooped
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 20:02'!
isStereo

	^ channelData size = 2
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 7/12/1998 18:26'!
leftSamples

	^ channelData at: 1
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 7/12/1998 18:30'!
loopEnd

	^ markers last last
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 7/12/1998 18:30'!
loopLength

	^ markers last last - markers first last
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 21:25'!
markers

	^ markers
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 7/12/1998 01:48'!
pitch

	^ pitch
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 19:34'!
rightSamples

	^ channelData at: 2
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 7/12/1998 18:25'!
samplingRate

	^ samplingRate
! !


!AIFFFileReader methodsFor: 'other' stamp: 'jm 8/17/1998 20:36'!
edit

	| ed |
	ed _ WaveEditor new.
	ed data: channelData first.
	ed loopEnd: markers last last.
	ed loopLength: (markers last last - markers first last) + 1.
	ed openInWorld.
! !

!AIFFFileReader methodsFor: 'other' stamp: 'jm 7/12/1998 01:44'!
pitchForKey: midiKey
	"Convert my MIDI key number to a pitch and return it."

	| indexInOctave octave p |
	indexInOctave _ (midiKey \\ 12) + 1.
	octave _ (midiKey // 12) + 1.
	"Table generator: (0 to: 11) collect: [:i | 16.3516 * (2.0 raisedTo: i asFloat / 12.0)]"
	p _ #(16.3516 17.32391 18.35405 19.44544 20.60173 21.82677
		  23.12466 24.49972 25.95655 27.50000 29.13524 30.86771) at: indexInOctave.
	^ p * (#(0.5 1.0 2.0 4.0 8.0 16.0 32.0 64.0 128.0 256.0 512.0) at: octave)
! !

!AIFFFileReader methodsFor: 'other' stamp: 'jm 1/14/1999 10:11'!
sound
	"Answer the sound represented by this AIFFFileReader. This method should be called only after readFrom: has been done."

	| snd rightSnd |
	snd _ SampledSound
		samples: (channelData at: 1)
		samplingRate: samplingRate.
	self isStereo ifTrue: [
		rightSnd _ SampledSound
			samples: (channelData at: 2)
			samplingRate: samplingRate.
		snd _ MixedSound new
			add: snd pan: 0;
			add: rightSnd pan: 1.0].
	^ snd
! !


!AIFFFileReader methodsFor: 'private' stamp: 'jm 6/29/1998 07:33'!
readChunk: chunkType size: chunkSize
	"Read a AIFF chunk of the given type. Skip unrecognized chunks. Leave the input stream positioned chunkSize bytes past its position when this method is called."

	chunkType = 'COMM' ifTrue: [^ self readCommonChunk: chunkSize].
	chunkType = 'SSND' ifTrue: [^ self readSamplesChunk: chunkSize].
	chunkType = 'INST' ifTrue: [^ self readInstrumentChunk: chunkSize].
	chunkType = 'MARK' ifTrue: [^ self readMarkerChunk: chunkSize].
	in skip: chunkSize.  "skip unknown chunks"
! !

!AIFFFileReader methodsFor: 'private' stamp: 'jm 7/12/1998 18:24'!
readCommonChunk: chunkSize
	"Read a COMM chunk. All AIFF files have exactly one chunk of this type."

	| compressionType |
	channelCount _ in nextNumber: 2.
	frameCount _ in nextNumber: 4.
	bitsPerSample _ in nextNumber: 2.
	samplingRate _ self readExtendedFloat.
	chunkSize > 18 ifTrue: [
		fileType = 'AIFF'
			ifTrue: [self error: 'unexpectedly long COMM chunk size for AIFF file'].
		compressionType _ (in next: 4) asString.
		compressionType = 'NONE' ifFalse: [self error: 'cannot read compressed AIFF files'].
		in skip: (chunkSize - 22)].  "skip the reminder of AIFF-C style chunk"
! !

!AIFFFileReader methodsFor: 'private' stamp: 'jm 6/29/1998 11:43'!
readExtendedFloat
	"Read and answer an Apple extended-precision 80-bit floating point number from the input stream."
	"Details: I could not find the specification for this format, so constants were determined empirically based on assumption of 1-bit sign, 15-bit exponent, 64-bit mantissa. This format does not seem to have an implicit one before the mantissa as some float formats do."

	| signAndExp mantissa sign exp |
	signAndExp _ in nextNumber: 2.
	mantissa _ in nextNumber: 8.  "scaled by (2 raisedTo: -64) below"
	(signAndExp bitAnd: 16r8000) = 0
		ifTrue: [sign _ 1.0]
		ifFalse: [sign _ -1.0].
	exp _ (signAndExp bitAnd: 16r7FFF) - 16r4000 + 2.  "not sure why +2 is needed..."
	^ (sign * mantissa asFloat * (2.0 raisedTo: exp - 64)) roundTo: 0.00000001
! !

!AIFFFileReader methodsFor: 'private' stamp: 'jm 8/2/1998 19:58'!
readFrom: aBinaryStream
	"Read AIFF data from the given binary stream."
	"Details: An AIFF file consists of a header (FORM chunk) followed by a sequence of tagged data chunks. Each chunk starts with a header consisting of a four-byte tag (a string) and a four byte size. These eight bytes of chunk header are not included in the chunk size. For each chunk, the readChunk:size: method consumes chunkSize bytes of the input stream, parsing recognized chunks or skipping unrecognized ones. If chunkSize is odd, it will be followed by a padding byte. Chunks may occur in any order."

	| sz end chunkType chunkSize p |
	in _ aBinaryStream.

	"read FORM chunk"
	(in next: 4) asString = 'FORM' ifFalse: [^ self error: 'not an AIFF file'].
	sz _ in nextNumber: 4.
	end _ in position + sz.
	fileType _ (in next: 4) asString.

	[in atEnd not and: [in position < end]] whileTrue: [
		chunkType _ (in next: 4) asString.
		chunkSize _ in nextNumber: 4.
		p _ in position.
		self readChunk: chunkType size: chunkSize.
		(in position = (p + chunkSize))
			ifFalse: [self error: 'chunk size mismatch; bad AIFF file?'].
		chunkSize odd ifTrue: [in skip: 1]].  "skip padding byte"
! !

!AIFFFileReader methodsFor: 'private' stamp: 'jm 8/5/1998 17:31'!
readInstrumentChunk: chunkSize

	| midiKey detune lowNote highNote lowVelocity highVelocity
	  sustainMode sustainStartID sustainEndID
	  releaseMode releaseStartID releaseEndID |

	midiKey _ in next.
	detune _ in next.
	lowNote _ in next.
	highNote _ in next.
	lowVelocity _ in next.
	highVelocity _ in next.
	gain _ in nextNumber: 2.
	sustainMode _ in nextNumber: 2.
	sustainStartID _ in nextNumber: 2.
	sustainEndID _ in nextNumber: 2.
	releaseMode _ in nextNumber: 2.
	releaseStartID _ in nextNumber: 2.
	releaseEndID _ in nextNumber: 2.
	isLooped _ sustainMode = 1.
	(isLooped and: [markers notNil]) ifTrue: [
		((markers first last > frameCount) or:
		 [markers last last > frameCount]) ifTrue: [
			"bad loop data; some sample CD files claim to be looped but aren't"
			isLooped _ false]].
	pitch _ self pitchForKey: midiKey.
! !

!AIFFFileReader methodsFor: 'private' stamp: 'jm 8/2/1998 21:22'!
readMarkerChunk: chunkSize

	| markerCount id position labelBytes label |
	markerCount _ in nextNumber: 2.
	markers _ Array new: markerCount.
	1 to: markerCount do: [:i |
		id _ in nextNumber: 2.
		position _ in nextNumber: 4.
		labelBytes _ in next.
		label _ (in next: labelBytes) asString.
		labelBytes even ifTrue: [in skip: 1].
		markers at: i put: (Array with: id with: label with: position)].

! !

!AIFFFileReader methodsFor: 'private' stamp: 'jm 8/2/1998 18:58'!
readMergedStereoChannelDataFrom: s
	"Read stereophonic channel data from the given stream, mixing the two channels to create a single monophonic channel. Each frame contains two samples."

	| buf w1 w2 |
	buf _ channelData at: 1.
	bitsPerSample = 8
		ifTrue: [
			1 to: frameCount do: [:i |
				w1 _ s next.
				w1 > 127 ifTrue: [w1 _ w1 - 256].
				w2 _ s next.
				w2 > 127 ifTrue: [w2 _ w2 - 256].
				buf at: i put: ((w1 + w2) bitShift: 7)]]
		ifFalse: [
			1 to: frameCount do: [:i |
				w1 _ (s next bitShift: 8) + s next.
				w1 > 32767 ifTrue: [w1 _ w1 - 65536].
				w2 _ (s next bitShift: 8) + s next.
				w2 > 32767 ifTrue: [w2 _ w2 - 65536].
				buf at: i put: ((w1 + w2) bitShift: -1)]].
! !

!AIFFFileReader methodsFor: 'private' stamp: 'jm 8/2/1998 18:53'!
readMonoChannelDataFrom: s
	"Read monophonic channel data from the given stream. Each frame contains a single sample."

	| buf w |
	buf _ channelData at: 1.  "the only buffer"
	bitsPerSample = 8
		ifTrue: [
			1 to: frameCount do: [:i |
				w _ s next.
				w > 127 ifTrue: [w _ w - 256].
				buf at: i put: (w bitShift: 8)]]
		ifFalse: [
			1 to: frameCount do: [:i |
				w _ (s next bitShift: 8) + s next.
				w > 32767 ifTrue: [w _ w - 65536].
				buf at: i put: w]].
! !

!AIFFFileReader methodsFor: 'private' stamp: 'jm 8/2/1998 18:55'!
readMultiChannelDataFrom: s
	"Read multi-channel data from the given stream. Each frame contains channelCount samples."

	| w |
	bitsPerSample = 8
		ifTrue: [
			1 to: frameCount do: [:i |
				1 to: channelCount do: [:ch |
					w _ s next.
					w > 127 ifTrue: [w _ w - 256].
					(channelData at: ch) at: i put: (w bitShift: 8)]]]
		ifFalse: [
			1 to: frameCount do: [:i |
				1 to: channelCount do: [:ch |
					w _ (s next bitShift: 8) + s next.
					w > 32767 ifTrue: [w _ w - 65536].
					(channelData at: ch) at: i put: w]]].
! !

!AIFFFileReader methodsFor: 'private' stamp: 'jm 10/20/2001 15:07'!
readSamplesChunk: chunkSize
	"Read a SSND chunk. All AIFF files with a non-zero frameCount contain exactly one chunk of this type."

	| offset blockSize bytesOfSamples s |
	offset _ in nextNumber: 4.
	blockSize _ in nextNumber: 4.
	((offset ~= 0) or: [blockSize ~= 0])
		ifTrue: [^ self error: 'this AIFF reader cannot handle blocked sample chunks'].
	bytesOfSamples _ chunkSize - 8.
	bytesOfSamples = (channelCount * frameCount * (bitsPerSample // 8))
		ifFalse: [self error: 'actual sample count does not match COMM chunk'].

	channelDataOffset _ in position.  "record stream position for start of data"
	skipDataChunk ifTrue: [in skip: (chunkSize - 8). ^ self].  "if skipDataChunk, skip sample data"

	(mergeIfStereo and: [channelCount = 2])
		ifTrue: [
			channelData _ Array with: (SoundBuffer newMonoSampleCount: frameCount)]
		ifFalse: [
			channelData _
				(1 to: channelCount) collect: [:i | SoundBuffer newMonoSampleCount: frameCount]].

	(bytesOfSamples < (Smalltalk garbageCollectMost - 300000))
		ifTrue: [s _ ReadStream on: (in next: bytesOfSamples)]  "bulk-read, then process"
		ifFalse: [s _ in].  "not enough space to buffer; read directly from file"

	"mono and stereo are special-cased for better performance"
	channelCount = 1 ifTrue: [^ self readMonoChannelDataFrom: s].
	channelCount = 2 ifTrue: [
		mergeIfStereo
			ifTrue: [channelCount _ 1. ^ self readMergedStereoChannelDataFrom: s]
			ifFalse: [^ self readStereoChannelDataFrom: s]].
	self readMultiChannelDataFrom: s.
! !

!AIFFFileReader methodsFor: 'private' stamp: 'jm 8/2/1998 18:56'!
readStereoChannelDataFrom: s
	"Read stereophonic channel data from the given stream. Each frame contains two samples."

	| left right w |
	left _ channelData at: 1.
	right _ channelData at: 2.
	bitsPerSample = 8
		ifTrue: [
			1 to: frameCount do: [:i |
				w _ s next.
				w > 127 ifTrue: [w _ w - 256].
				left at: i put: (w bitShift: 8).
				w _ s next.
				w > 127 ifTrue: [w _ w - 256].
				right at: i put: (w bitShift: 8)]]
		ifFalse: [
			1 to: frameCount do: [:i |
				w _ (s next bitShift: 8) + s next.
				w > 32767 ifTrue: [w _ w - 65536].
				left at: i put: w.
				w _ (s next bitShift: 8) + s next.
				w > 32767 ifTrue: [w _ w - 65536].
				right at: i put: w]].
! !
EllipseMorph subclass: #AlertMorph
	instanceVariableNames: 'onColor offColor myObjSock socketOwner'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Audio Chat'!

!AlertMorph methodsFor: 'accessing' stamp: 'TBP 3/5/2000 13:47'!
color: aColor

	super color: aColor.
	onColor _ aColor.! !

!AlertMorph methodsFor: 'accessing' stamp: 'mir 8/31/2004 15:47'!
onColor
	^onColor ifNil: [onColor := Color green]! !


!AlertMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/2/2000 10:39'!
socketOwner: aChatGUI

	socketOwner _ aChatGUI.! !


!AlertMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:11'!
defaultBorderWidth
"answer the default border width for the receiver"
	^ 2! !

!AlertMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:11'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color red! !

!AlertMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:11'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self extent: 25 @ 25.
! !


!AlertMorph methodsFor: 'stepping and presenter' stamp: 'mir 8/31/2004 15:47'!
step

	super step.
	offColor ifNil: [offColor _ self onColor mixed: 0.5 with: Color black].
	socketOwner objectsInQueue = 0 ifTrue: [
		color = offColor ifFalse: [super color: offColor].
	] ifFalse: [
		super color: (color = onColor ifTrue: [offColor] ifFalse: [onColor]).
	].
! !


!AlertMorph methodsFor: 'testing' stamp: 'TBP 3/5/2000 13:47'!
stepTime
	"Answer the desired time between steps in milliseconds."

	^ 500! !


!AlertMorph methodsFor: 'visual properties' stamp: 'TBP 3/5/2000 13:47'!
canHaveFillStyles
	^false! !
RectangleMorph subclass: #AlignmentMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!
!AlignmentMorph commentStamp: 'kfr 10/27/2003 10:25' prior: 0!
Used for layout.
Since all morphs now support layoutPolicy the main use of this class is no longer needed.
Kept around for compability. 
Supports a few methods not found elsewhere that can be convenient, eg. newRow
!


!AlignmentMorph methodsFor: 'classification' stamp: 'di 5/7/1998 01:20'!
isAlignmentMorph

	^ true
! !


!AlignmentMorph methodsFor: 'e-toy support' stamp: 'panda 4/25/2000 15:44'!
configureForKids
	self disableDragNDrop.
	super configureForKids
! !


!AlignmentMorph methodsFor: 'event handling' stamp: 'sw 5/6/1998 15:58'!
wantsKeyboardFocusFor: aSubmorph
	aSubmorph wouldAcceptKeyboardFocus ifTrue: [^ true].
	^ super wantsKeyboardFocusFor: aSubmorph! !


!AlignmentMorph methodsFor: 'initialization' stamp: 'tak 9/26/2006 21:08'!
addUpDownArrowsFor: aMorph
	"Add a column of up and down arrows that serve to send upArrowHit and downArrowHit to aMorph when they're pressed/held down"

	| downArrow upArrow |
	(TileMorph addArrowsOn: self)
		in: [:array | 
			upArrow := array first.
			downArrow := array second].
	upArrow on: #mouseDown send: #upArrowHit to: aMorph.
	upArrow on: #mouseStillDown send: #upArrowHit to: aMorph.
	downArrow on: #mouseDown send: #downArrowHit to: aMorph.
	downArrow on: #mouseStillDown send: #downArrowHit to: aMorph.! !

!AlignmentMorph methodsFor: 'initialization' stamp: 'sw 10/15/2006 02:08'!
addVariableTransparentSpacer
	"Add a new variable transparent receiver to the receiver."

	self addMorphBack: AlignmentMorph newVariableTransparentSpacer! !

!AlignmentMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:02'!
basicInitialize
	"Do basic generic initialization of the instance variables"
	super basicInitialize.
	""
	self layoutPolicy: TableLayout new;
	  listDirection: #leftToRight;
	  wrapCentering: #topLeft;
	  hResizing: #spaceFill;
	  vResizing: #spaceFill;
	  layoutInset: 2;
	  rubberBandCells: true! !

!AlignmentMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 0! !

!AlignmentMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color
		r: 0.8
		g: 1.0
		b: 0.8! !

!AlignmentMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:19'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self layoutPolicy: TableLayout new;
	 listDirection: #leftToRight;
	 wrapCentering: #topLeft;
	 hResizing: #spaceFill;
	 vResizing: #spaceFill;
	 layoutInset: 2;
	 rubberBandCells: true! !

!AlignmentMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 20:34'!
openInWindowLabeled: aString inWorld: aWorld

	self layoutInset: 0.
	^super openInWindowLabeled: aString inWorld: aWorld.! !


!AlignmentMorph methodsFor: 'object fileIn' stamp: 'gm 2/22/2003 13:12'!
convertOldAlignmentsNov2000: varDict using: smartRefStrm 
	"major change - much of AlignmentMorph is now implemented more generally in Morph"

	"These are going away 
	#('orientation' 'centering' 'hResizing' 'vResizing' 
	'inset' 'minCellSize' 'layoutNeeded' 'priorFullBounds')"

	| orientation centering hResizing vResizing inset minCellSize inAlignment |
	orientation := varDict at: 'orientation'.
	centering := varDict at: 'centering'.
	hResizing := varDict at: 'hResizing'.
	vResizing := varDict at: 'vResizing'.
	inset := varDict at: 'inset'.
	minCellSize := varDict at: 'minCellSize'.
	(orientation == #horizontal or: [orientation == #vertical]) 
		ifTrue: [self layoutPolicy: TableLayout new].
	self cellPositioning: #topLeft.
	self rubberBandCells: true.
	orientation == #horizontal ifTrue: [self listDirection: #leftToRight].
	orientation == #vertical ifTrue: [self listDirection: #topToBottom].
	centering == #topLeft ifTrue: [self wrapCentering: #topLeft].
	centering == #bottomRight ifTrue: [self wrapCentering: #bottomRight].
	centering == #center 
		ifTrue: 
			[self wrapCentering: #center.
			orientation == #horizontal 
				ifTrue: [self cellPositioning: #leftCenter]
				ifFalse: [self cellPositioning: #topCenter]].
	(inset isNumber or: [inset isPoint]) ifTrue: [self layoutInset: inset].
	(minCellSize isNumber or: [minCellSize isPoint]) 
		ifTrue: [self minCellSize: minCellSize].
	(self hasProperty: #clipToOwnerWidth) ifTrue: [self clipSubmorphs: true].

	"now figure out if our owner was an AlignmentMorph, even if it is reshaped..."
	inAlignment := false.
	owner isMorph 
		ifTrue: [(owner isAlignmentMorph) ifTrue: [inAlignment := true]]
		ifFalse: 
			["e.g., owner may be reshaped"

			(owner class instanceVariablesString 
				findString: 'orientation centering hResizing vResizing') > 0 
				ifTrue: 
					["this was an alignment morph being reshaped"

					inAlignment := true]].
	"And check for containment in system windows"
	owner isSystemWindow ifTrue: [inAlignment := true].
	(hResizing == #spaceFill and: [inAlignment not]) 
		ifTrue: [self hResizing: #shrinkWrap]
		ifFalse: [self hResizing: hResizing].
	(vResizing == #spaceFill and: [inAlignment not]) 
		ifTrue: [self vResizing: #shrinkWrap]
		ifFalse: [self vResizing: vResizing]! !


!AlignmentMorph methodsFor: 'objects from disk' stamp: 'tk 11/26/2004 05:51'!
convertToCurrentVersion: varDict refStream: smartRefStrm

	| newish |
	newish _ super convertToCurrentVersion: varDict refStream:
smartRefStrm.

	"major change - much of AlignmentMorph is now implemented
more generally in Morph"
	varDict at: 'hResizing' ifPresent: [ :x |
		^ newish convertOldAlignmentsNov2000: varDict using:
smartRefStrm].
	^ newish
! !


!AlignmentMorph methodsFor: 'visual properties' stamp: 'sw 11/5/2001 15:11'!
canHaveFillStyles
	"Return true if the receiver can have general fill styles; not just colors.
	This method is for gradually converting old morphs."

	^ self class == AlignmentMorph "no subclasses"! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AlignmentMorph class
	instanceVariableNames: ''!

!AlignmentMorph class methodsFor: 'instance creation' stamp: 'dgd 9/20/2003 19:05'!
columnPrototype
	"Answer a prototypical column"

	| sampleMorphs aColumn |
	sampleMorphs _ #(red yellow green) collect:
		[:aColor | Morph new extent: 130 @ 38; color: (Color perform: aColor); setNameTo: aColor asString; yourself].
	aColumn _ self inAColumn: sampleMorphs.
	aColumn setNameTo: 'Column'.
	aColumn color: Color veryVeryLightGray.
	aColumn cellInset: 4; layoutInset: 6.
	aColumn enableDragNDrop.
	aColumn setBalloonText: 'Things dropped into here will automatically be organized into a column. Once you have added your own items here, you will want to remove the sample colored rectangles that this started with, and you will want to change this balloon help message to one of your own!!' translated.
	^ aColumn! !

!AlignmentMorph class methodsFor: 'instance creation' stamp: 'sw 11/2/2001 04:45'!
inAColumn: aCollectionOfMorphs
	"Answer a columnar AlignmentMorph holding the given collection"

	| col |
	col _ self newColumn
		color: Color transparent;
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap;
		layoutInset: 1;
		borderColor: Color black;
		borderWidth: 1;
		wrapCentering: #center;
		cellPositioning: #topCenter.
	aCollectionOfMorphs do: [:each | col addMorphBack: each].
	^ col! !

!AlignmentMorph class methodsFor: 'instance creation' stamp: 'sw 11/5/2001 15:11'!
inARow: aCollectionOfMorphs
	"Answer a row-oriented AlignmentMorph holding the given collection"

	| aRow |
	aRow _ self newRow
		color: Color transparent;
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap;
		layoutInset: 1;
		borderColor: Color black;
		borderWidth: 1;
		wrapCentering: #center;
		cellPositioning: #topCenter.
	aCollectionOfMorphs do: [ :each | aRow addMorphBack: each].
	^ aRow! !

!AlignmentMorph class methodsFor: 'instance creation' stamp: 'ar 11/9/2000 20:51'!
newColumn

	^ self new
		listDirection: #topToBottom;
		hResizing: #spaceFill;
		extent: 1@1;
		vResizing: #spaceFill
! !

!AlignmentMorph class methodsFor: 'instance creation' stamp: 'ar 11/9/2000 20:50'!
newRow

	^ self new
		listDirection: #leftToRight;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		extent: 1@1;
		borderWidth: 0
! !

!AlignmentMorph class methodsFor: 'instance creation' stamp: 'ar 11/9/2000 20:37'!
newSpacer: aColor
	"Answer a space-filling instance of me of the given color."

	^ self new
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		layoutInset: 0;
		borderWidth: 0;
		extent: 1@1;
		color: aColor.
! !

!AlignmentMorph class methodsFor: 'instance creation' stamp: 'sw 9/2/2007 15:06'!
newVariableTransparentSpacer
	"Answer a new variable tranparent spacer."

	^ VariableSpacer new! !

!AlignmentMorph class methodsFor: 'instance creation' stamp: 'dgd 9/20/2003 19:05'!
rowPrototype
	"Answer a prototypical row"

	| sampleMorphs aRow |
	sampleMorphs _ (1 to: (2 + 3 atRandom)) collect:
		[:integer | EllipseMorph new extent: ((60 + (20 atRandom)) @ (80 + ((20 atRandom)))); color: Color random; setNameTo: ('egg',  integer asString); yourself].
	aRow _ self inARow: sampleMorphs.
	aRow setNameTo: 'Row'.
	aRow enableDragNDrop.
	aRow cellInset: 6.
	aRow layoutInset: 8.
	aRow setBalloonText: 'Things dropped into here will automatically be organized into a row. Once you have added your own items here, you will want to remove the sample colored eggs that this started with, and you will want to change this balloon help message to one of your own!!' translated.
	aRow color: Color veryVeryLightGray.
	^ aRow

			"AlignmentMorph rowPrototype openInHand"! !


!AlignmentMorph class methodsFor: 'parts bin' stamp: 'tak 7/25/2007 00:02'!
supplementaryPartsDescriptions
	"Extra items for parts bins"

	^ {DescriptionForPartsBin
		formalName: 'Column' translatedNoop
		categoryList: #()
		documentation: 'An object that presents the things within it in a column' translatedNoop
		globalReceiverSymbol: #AlignmentMorph
		nativitySelector: #columnPrototype.
	DescriptionForPartsBin
		formalName: 'Row' translatedNoop
		categoryList: #()
		documentation: 'An object that presents the things within it in a row' translatedNoop
		globalReceiverSymbol: #AlignmentMorph
		nativitySelector: #rowPrototype}! !


!AlignmentMorph class methodsFor: 'scripting' stamp: 'sw 11/16/2001 10:01'!
additionsToViewerCategories
	"Answer viewer additions for the 'layout' category"

	^#((
		layout 
		(
			(slot cellInset 'The cell inset' Number readWrite Player getCellInset Player setCellInset:)
			(slot layoutInset 'The layout inset' Number readWrite Player getLayoutInset Player setLayoutInset:)
			(slot listCentering 'The list centering' ListCentering readWrite Player getListCentering Player setListCentering:)
			(slot hResizing  	'Horizontal resizing' Resizing readWrite Player 	getHResizing Player setHResizing:)
			(slot vResizing  	'Vertical resizing' Resizing readWrite Player 	getVResizing Player setVResizing:)
			(slot listDirection  'List direction' ListDirection readWrite Player 	getListDirection Player setListDirection:)
			(slot wrapDirection 'Wrap direction' ListDirection readWrite Player 	getWrapDirection Player setWrapDirection:)
		)))
! !

!AlignmentMorph class methodsFor: 'scripting' stamp: 'sw 11/16/2004 00:44'!
defaultNameStemForInstances
	"The code just below, now commented out, resulted in every instance of every sublcass of AlignmentMorph being given a default name of the form 'Alignment1', rather than the desired 'MoviePlayer1', 'ScriptEditor2', etc."

	"^ 'Alignment'"

	^ super defaultNameStemForInstances! !
AlignmentMorph subclass: #AlignmentMorphBob1
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Experimental'!
!AlignmentMorphBob1 commentStamp: '<historical>' prior: 0!
A quick and easy to space things vertically in absolute or proportional amounts.!


!AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'RAA 3/10/2001 13:54'!
acceptDroppingMorph: aMorph event: evt

	| handlerForDrops |

	handlerForDrops _ self valueOfProperty: #handlerForDrops ifAbsent: [
		^super acceptDroppingMorph: aMorph event: evt
	].
	(handlerForDrops acceptDroppingMorph: aMorph event: evt in: self) ifFalse: [
		aMorph rejectDropMorphEvent: evt.		"send it back where it came from"
	].! !

!AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'RAA 7/23/2000 16:42'!
addAColumn: aCollectionOfMorphs

	| col |
	col _ self inAColumn: aCollectionOfMorphs.
	self addMorphBack: col.
	^col! !

!AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'RAA 7/23/2000 16:42'!
addARow: aCollectionOfMorphs

	| row |
	row _ self inARow: aCollectionOfMorphs.
	self addMorphBack: row.
	^row! !

!AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 21:09'!
addARowCentered: aCollectionOfMorphs

	^(self addARow: aCollectionOfMorphs)
		hResizing: #shrinkWrap;
		wrapCentering: #center;
		cellPositioning: #leftCenter! !

!AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'dgd 8/27/2004 18:26'!
fancyText: aString ofSize: pointSize color: aColor

	| answer tm |
	answer _ self inAColumn: {
		tm _ TextMorph new 
			beAllFont: ((TextStyle default fontOfSize: pointSize) emphasized: 1);
			color: aColor;
			contents: aString
	}.
	tm addDropShadow.
	tm shadowPoint: (5@5) + tm bounds center.
	tm lock.
	^answer
! !

!AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'ar 12/30/2001 19:14'!
fullDrawOn: aCanvas

	| mask |
	(aCanvas isVisible: self fullBounds) ifFalse:[^self].
	super fullDrawOn: aCanvas.
	mask _ self valueOfProperty: #disabledMaskColor ifAbsent: [^self].
	aCanvas fillRectangle: bounds color: mask.
! !

!AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 21:10'!
inAColumn: aCollectionOfMorphs

	| col |
	col _ AlignmentMorph newColumn
		color: Color transparent;
		vResizing: #shrinkWrap;
		layoutInset: 1;
		wrapCentering: #center;
		cellPositioning: #topCenter.
	aCollectionOfMorphs do: [ :each | col addMorphBack: each].
	^col! !

!AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 21:10'!
inARow: aCollectionOfMorphs

	| row |
	row _ AlignmentMorph newRow
		color: Color transparent;
		vResizing: #shrinkWrap;
		layoutInset: 1;
		wrapCentering: #center;
		cellPositioning: #leftCenter.
	aCollectionOfMorphs do: [ :each | row addMorphBack: each].
	^row! !

!AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'tak 10/14/2006 14:15'!
initialize

	super initialize.
	self listDirection: #topToBottom.
	self layoutInset: 0.
	self hResizing: #rigid. "... this is very unlikely..."
	self vResizing: #rigid.
! !

!AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 10:43'!
simpleToggleButtonFor: target attribute: attribute help: helpText

	^(EtoyUpdatingThreePhaseButtonMorph checkBox)
		target: target;
		actionSelector: #toggleChoice:;
		arguments: {attribute};
		getSelector: #getChoice:;
		setBalloonText: helpText;
		step

! !

!AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'RAA 3/14/2001 08:36'!
wantsDroppedMorph: aMorph event: evt

	| handlerForDrops |

	handlerForDrops _ self valueOfProperty: #handlerForDrops ifAbsent: [
		^super wantsDroppedMorph: aMorph event: evt
	].
	^handlerForDrops wantsDroppedMorph: aMorph event: evt in: self! !


!AlignmentMorphBob1 methodsFor: 'olpc support' stamp: 'yo 9/28/2006 14:25'!
fancyText: aString font: aFont color: aColor
	"Answer a morph containing a TextMorph containing the given string in the given font with the given color."

	| answer tm |
	answer _ self inAColumn: {
		tm _ TextMorph new 
			textColor: aColor;
			contents: aString;
			beAllFont: aFont;
			yourself
	}.

	tm lock.
	^ answer
! !
AlignmentMorph subclass: #AllPlayersTool
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting'!
!AllPlayersTool commentStamp: '<historical>' prior: 0!
A tool that lets you see find, view, and obtain tiles for all the active players in the project.!


!AllPlayersTool methodsFor: 'initialization' stamp: 'sw 5/20/2007 03:28'!
addHeaderRow
	"Add the header morph at the top of the tool"

	| aRow aButton |
	aRow _ AlignmentMorph newRow.
	aRow listCentering: #justified; color: Color transparent.
	aButton _ self tanOButton.
	aRow addMorphFront: aButton.
	aRow addMorphBack: (StringMorph contents: 'Players in this Project' translated font: ScriptingSystem fontForTiles).

	aRow addMorphBack: self helpButton.
	self addMorphFront: aRow.
! !

!AllPlayersTool methodsFor: 'initialization' stamp: 'sw 5/24/2007 05:11'!
initializeFor: aPresenter
	"Initialize the receiver as a tool which shows, and allows the user to change the status of, all the instantiations of all the user-written scripts in the scope of the containing pasteup's presenter"

	| placeHolder |
	self color: Color brown muchLighter muchLighter; wrapCentering: #center; cellPositioning: #topCenter; vResizing: #shrinkWrap; hResizing: #shrinkWrap.
	self useRoundedCorners.
	self layoutInset: 0.
	self borderStyle: BorderStyle complexAltInset; borderWidth: 4; borderColor: (Color r: 0.452 g: 0.839 b: 1.0).  "Color fromUser"
	self addHeaderRow.
	placeHolder _ Morph new beTransparent.
	placeHolder extent: 200@0.
	self addMorphBack: placeHolder.
	self setProperty: #ExplicitStepTime toValue: 5000.  "5 seconds"
	WorldState addDeferredUIMessage:
		[self updateScrollbar.
		self reinvigorate]

! !

!AllPlayersTool methodsFor: 'initialization' stamp: 'sw 7/28/2004 18:08'!
initializeToStandAlone
	"Initialize the receiver"

	super initializeToStandAlone.
	self layoutPolicy: TableLayout new;
		listDirection: #topToBottom;
		hResizing: #spaceFill;
		extent: 1@1;
		vResizing: #spaceFill;
		rubberBandCells: true;
		yourself.

	self initializeFor: self currentWorld presenter! !

!AllPlayersTool methodsFor: 'initialization' stamp: 'sw 5/18/2007 02:07'!
setExtentFromHalo: anExtent
	"The user has dragged the grow box such that the receiver's extent would be anExtent.  Do what's needed."

	submorphs size > 2 ifFalse: [^ super setExtentFromHalo: anExtent].
	submorphs third extent: ((anExtent x  - 8) @ (anExtent y - 41))! !

!AllPlayersTool methodsFor: 'initialization' stamp: 'sw 5/16/2007 13:34'!
updateScrollbar
	"Every subsystem needs a little bit of inscrutable magic"

	self setExtentFromHalo: ((self extent x max:300) @ (self extent y max: 400))! !


!AllPlayersTool methodsFor: 'reinvigoration' stamp: 'sw 7/19/2004 16:37'!
invigorateButton
	"Answer a button that triggers reinvigoration"

	| aButton |
	aButton _ IconicButton new target: self;
		borderWidth: 0;
		labelGraphic: (ScriptingSystem formAtKey: #Refresh);
		color: Color transparent; 
		actWhen: #buttonUp;
		actionSelector: #reinvigorate;
		yourself.
	aButton setBalloonText: 'Click here to refresh the list of players'.
	^ aButton
! !

!AllPlayersTool methodsFor: 'reinvigoration' stamp: 'sw 7/19/2004 16:17'!
menuButton
	"Answer a button that brings up a menu.  Useful when adding new features, but at present is between uses"

	| aButton |
	aButton _ IconicButton new target: self;
		borderWidth: 0;
		labelGraphic: (ScriptingSystem formAtKey: #TinyMenu);
		color: Color transparent; 
		actWhen: #buttonDown;
		actionSelector: #offerMenu;
		yourself.
	aButton setBalloonText: 'click here to get a menu with further options'.
	^ aButton
! !

!AllPlayersTool methodsFor: 'reinvigoration' stamp: 'sw 5/25/2007 01:39'!
playersOnDisplay
	"Answer a list of the players represented by the rows in the tool."

	| aList |
	(submorphs size < 3 or: [(submorphs third isKindOf: ScrollPane) not]) ifTrue: [^ #()].

	aList := submorphs third scroller firstSubmorph submorphs collect:
		[:aRow | aRow playerRepresented].
	^ aList copyWithout: nil! !

!AllPlayersTool methodsFor: 'reinvigoration' stamp: 'sw 11/21/2007 09:27'!
reinvigorate
	"Rebuild the contents of the Players tool"

	| firstTwo oldList newList rowsForPlayers rowsWrapper outer existingThird oldExtent |
	firstTwo _ {self submorphs first.  self submorphs second}.
	existingThird := (self submorphs size > 2)
		ifTrue:	[self submorphs third]
		ifFalse:	[nil].

	oldExtent := existingThird 
		ifNotNil:
			[existingThird extent]
		ifNil:
			[300 @ 460].
	oldList := self playersOnDisplay asOrderedCollection.
	self presenter flushPlayerListCache.
	newList _ self presenter reallyAllExtantPlayers.
	oldList asSet = newList asSet
		ifFalse:
			[self removeAllMorphs; addAllMorphs: firstTwo.

			rowsForPlayers _ newList collect:
				[:aPlayer |
					aPlayer costume assureExternalName.
					aPlayer entryForPlayersTool: self].

			rowsWrapper := AlignmentMorph newColumn.
			rowsWrapper hResizing: #shrinkWrap; beTransparent.
			rowsWrapper addAllMorphs: rowsForPlayers.

			outer := ScrollPane new extent: oldExtent.
			outer minWidth: firstTwo first width.
			outer model: self presenter.
			outer useRoundedCorners.
			outer scrollBarOnLeft: false.
			outer scroller addMorph: rowsWrapper.
			outer retractable: false.
			outer hideHScrollBarIndefinitely: true.
			outer alwaysShowHScrollBar: true.
			outer borderWidth: 1; borderColor: Color gray.

			self addMorphBack: outer.

			self updateScrollbar]! !


!AllPlayersTool methodsFor: 'menus' stamp: 'sw 7/28/2004 18:32'!
addCustomMenuItems: aMenu hand: aHand
	"Add further items to the menu"

	aMenu add: 'reinvigorate' target: self action: #reinvigorate.
	Preferences eToyFriendly ifFalse: [aMenu add: 'inspect' target: self action: #inspect]! !

!AllPlayersTool methodsFor: 'menus' stamp: 'sw 5/22/2007 03:34'!
helpString
	"Answer a string of help"

	^ 'Each row represents an object, or "player" in the project.
Click on the menu icon to get a menu of options concerning the player.
Click on a player''s picture to reveal its location.
Click on the turquoise eye to open the player''s viewer.
Click on a player''s name to obtain a tile representing it.'
 translated.! !

!AllPlayersTool methodsFor: 'menus' stamp: 'sw 5/20/2007 03:34'!
presentHelp
	"Sent when a Help button is hit; provide the user with some form of help for the tool at hand"

	| aFlapTab aString |
	aString _ '
Each row represents an object, or "player" in the project.
Click on the menu icon to get a menu of options concerning the player.
Click on a player''s picture to reveal its location.
Click on the turquoise eye to open the player''s viewer.
Click on a player''s name to obtain a tile representing it.'
 translated.

	aFlapTab := ScriptingSystem assureFlapOfLabel: 'Players' translated withContents: aString.
	aFlapTab showFlap! !


!AllPlayersTool methodsFor: 'stepping' stamp: 'sw 5/24/2007 05:11'!
step
	"Periodically..."

	self reinvigorate! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AllPlayersTool class
	instanceVariableNames: ''!

!AllPlayersTool class methodsFor: 'parts bin' stamp: 'sw 5/24/2007 19:06'!
allPlayersToolForActiveWorld
	"Launch an AllPlayersTool to view the scripted objects of the active world"

	| aTool |
	aTool _ self newStandAlone.
	aTool center: ActiveWorld center.
	^ aTool

"
AllPlayersTool allPlayersToolForActiveWorld
"! !

!AllPlayersTool class methodsFor: 'parts bin' stamp: 'tak 7/25/2007 00:03'!
descriptionForPartsBin
	"Answer a description for use in parts bins"

	^ self partName: 	'Players' translatedNoop
		categories:		{'Scripting' translatedNoop}
		documentation:	'A tool showing all the players in your project' translatedNoop! !


!AllPlayersTool class methodsFor: 'instance-creation defaults' stamp: 'sw 7/19/2004 10:38'!
defaultNameStemForInstances
	"Answer the default name stem for new instances of this class"

	^ 'Players'! !
AlignmentMorph subclass: #AllScriptsTool
	instanceVariableNames: 'showingOnlyActiveScripts showingAllInstances showingOnlyTopControls'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting'!
!AllScriptsTool commentStamp: '<historical>' prior: 0!
A tool for controlling and viewing all scripts in a project.  The tool has an open and a closed form.  In the closed form, stop-step-go buttons are available, plus a control for opening the tool up.  In the open form, it has a second row of controls that govern which scripts should be shown, followed by the individual script items.!


!AllScriptsTool methodsFor: 'initialization' stamp: 'sw 7/22/2007 18:00'!
addSecondLineOfControls
	"Add the second line of controls"

	| aRow outerButton aButton worldToUse |
	aRow _ AlignmentMorph newRow listCentering: #center; color: Color transparent.
	outerButton _ AlignmentMorph newRow.
	outerButton wrapCentering: #center; cellPositioning: #leftCenter.
	outerButton color:  Color transparent.
	outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	outerButton addMorph: (aButton _ UpdatingThreePhaseButtonMorph checkBox).
	aButton
		target: self;
		actionSelector: #toggleWhetherShowingOnlyActiveScripts;
		getSelector: #showingOnlyActiveScripts.
	outerButton addTransparentSpacerOfSize: (4@0).
	outerButton addMorphBack: (StringMorph contents: 'tickers only' translated font: ScriptingSystem fontForEToyButtons) lock.
	outerButton setBalloonText: 'If checked, then only scripts that are paused or ticking will be shown' translated.
	aRow addMorphBack: outerButton.

	aRow addTransparentSpacerOfSize: 20@0.
	aRow addMorphBack: self helpButton.

	aRow addTransparentSpacerOfSize: 20@0.

	outerButton _ AlignmentMorph newRow.
	outerButton wrapCentering: #center; cellPositioning: #leftCenter.
	outerButton color:  Color transparent.
	outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	outerButton addMorph: (aButton _ UpdatingThreePhaseButtonMorph checkBox).
	aButton
		target: self;
		actionSelector: #toggleWhetherShowingAllInstances;
		getSelector: #showingAllInstances.
	outerButton addTransparentSpacerOfSize: (4@0).
	outerButton addMorphBack: (StringMorph contents: 'all instances' translated font: ScriptingSystem fontForEToyButtons) lock.
	outerButton setBalloonText: 'If checked, then entries for all instances will be shown, but if not checked, scripts for only one representative of each different kind of object will be shown.  Consult the help available by clicking on the purple ? for more information.' translated.
	aRow addMorphBack: outerButton.

	self addMorphBack: aRow.
	worldToUse _ self isInWorld ifTrue: [self world] ifFalse: [ActiveWorld].
	worldToUse presenter reinvigorateAllScriptsTool: self.
	self layoutChanged.! !

!AllScriptsTool methodsFor: 'initialization' stamp: 'dgd 8/31/2003 19:43'!
dismissButton
	"Answer a button whose action would be to dismiss the 
	receiver "
	| aButton |
	aButton := super dismissButton.
	aButton setBalloonText: 'Click here to remove this tool from the screen; you can get another one any time you want from the Widgets flap' translated.
	^ aButton! !

!AllScriptsTool methodsFor: 'initialization' stamp: 'sw 2/20/2007 03:29'!
helpString
	"Answer the help string for the all-scripts tool."

	^
'This tool allows you to see all the scripts for all the objects in this project.

Sometimes you are only interested in those scripts that are ticking, or that are *ready* to tick when you hit the GO button (which are said to be "paused.")

* Check "tickers only" if you only want to see such scripts -- i.e., scripts that are either paused or ticking.

* If "tickers only" is *not* checked, then all scripts will be shown, whatever their status.

* The other checkbox, labeled "all instances", only comes into play if you have created "multiple sibling instances" (good grief) of the same object, which share the same scripts; if you have such things, it is often convenient to see the scripts of just *one* such sibling, because it will take up less space and require less mindshare -- and note that you can control a script for an object *and* all its siblings from the menu of that one that you see, via menu items such as "propagate status to siblings".

* If "all instances" is checked, scripts for all sibling instances will be shown, whereas if "all instances" is *not* checked, only one of each group of siblings will be selected to have its scripts shown.

But how do you get "multiple sibling instances" of the same object?  There are several ways:

(1)  Use the "make a sibling instance" or the "make multiple siblings..." menu item in the halo menu of a scripted object.

(2)  Use the "copy" tile in a script.

(3)  Request "give me a copy now" from the menu associated with the "copy" item in a Viewer.

If you have on your screen multiple sibling instances of the same object, then you may or may want to see them all in the All Scripts tool, and that is what the "all instances" checkbox governs.

Set "all instances" if you want a separate entry for each instance, as
opposed to a single representative of that kind of object.

Note that if you obtain a copy of an object by using the green halo handle, it will *not* be a sibling instance of the original.  It will in many ways seem to be, because it will start out its life having the same scripts as the original.  But it will then lead an independent life, so that changes to scripts of the original will not be reflected in it, and vice-versa.

This is an important distinction, and an unavoidable one because people sometimes want the deep sharing of sibling instances and sometimes they clearly do not.  But the truly understandable description of these concepts and distinctions certainly lies *ahead* of us!!' translated! !

!AllScriptsTool methodsFor: 'initialization' stamp: 'tak 3/27/2007 17:27'!
initializeFor: ignored
	"Initialize the receiver as a tool which shows, and allows the user to change the status of, all the instantiations of all the user-written scripts in the scope of the containing pasteup's presenter"

	| aRow aButton |
	showingOnlyActiveScripts _ true.
	showingAllInstances _ true.
	showingOnlyTopControls _ true.
	self color: Color brown muchLighter muchLighter; wrapCentering: #center; cellPositioning: #topCenter; vResizing: #shrinkWrap; hResizing: #shrinkWrap.
	self useRoundedCorners.
	self borderWidth: 4; borderColor: Color brown darker.
	aRow _ AlignmentMorph newRow.
	aRow listCentering: #justified; color: Color transparent.
	aButton _ self tanOButton.
	aRow addMorphFront: aButton.
	aRow addTransparentSpacerOfSize: 10.
	aRow addMorphBack: ScriptingSystem scriptControlButtons.
	aRow addTransparentSpacerOfSize: 10.
	aRow addMorphBack: self openUpButton.
	self addMorphFront: aRow.

! !

!AllScriptsTool methodsFor: 'initialization' stamp: 'sw 2/20/2007 03:30'!
presentHelp
	"Sent when a Help button is hit; provide the user with some form of help for the tool at hand"

	| aFlapTab |
	aFlapTab := ScriptingSystem assureFlapOfLabel: 'All Scripts' translated withContents: self helpString.
	aFlapTab showFlap! !


!AllScriptsTool methodsFor: 'parts bin' stamp: 'dgd 2/22/2003 19:37'!
initializeToStandAlone
	super initializeToStandAlone.
	self
		layoutPolicy: TableLayout new;
		listDirection: #topToBottom;
		hResizing: #spaceFill;
		extent: 1 @ 1;
		vResizing: #spaceFill;
		rubberBandCells: true.
	self initializeFor: self currentWorld presenter! !


!AllScriptsTool methodsFor: 'stepping and presenter' stamp: 'sw 11/14/2001 00:31'!
step
	"If the list of scripts to show has changed, refresh my contents"

	self showingOnlyTopControls ifFalse:
		[self presenter reinvigorateAllScriptsTool: self].! !


!AllScriptsTool methodsFor: 'testing' stamp: 'sw 1/31/2001 23:12'!
stepTime
	"Answer the interval between steps -- in this case a leisurely 4 seconds"

	^ 4000! !

!AllScriptsTool methodsFor: 'testing' stamp: 'sw 1/31/2001 23:12'!
wantsSteps
	"Answer whether the receiver wishes to receive the #step message"

	 ^ true! !


!AllScriptsTool methodsFor: 'toggles' stamp: 'tak 1/11/2007 15:48'!
openUpButton
	"Answer a button whose action would be to open up the receiver or snap it back closed"

	| aButton |
	aButton := UpdatingThreePhaseButtonMorph blackTriangularOpener.
	aButton getSelector: #showingOnlyTopControls.
	aButton
		target: self;
		actionSelector: #toggleWhetherShowingOnlyTopControls;
		setBalloonText: 'open or close the lower portion that shows individual scripts' translated.
	^ aButton! !

!AllScriptsTool methodsFor: 'toggles' stamp: 'sw 1/30/2001 23:18'!
showingAllInstances
	"Answer whether the receiver is currently showing controls for all instances of each uniclass."
 
	^ showingAllInstances ! !

!AllScriptsTool methodsFor: 'toggles' stamp: 'sw 1/30/2001 23:18'!
showingOnlyActiveScripts
	"Answer whether the receiver is currently showing only active scripts"
 
	^ showingOnlyActiveScripts ! !

!AllScriptsTool methodsFor: 'toggles' stamp: 'sw 11/13/2001 19:43'!
showingOnlyTopControls
	"Answer whether the receiver is currently showing only the top controls"
 
	^ showingOnlyTopControls ifNil: [showingOnlyTopControls _ true]! !

!AllScriptsTool methodsFor: 'toggles' stamp: 'sw 11/14/2001 00:32'!
toggleWhetherShowingAllInstances
	"Toggle whether the receiver is showing all instances or only one exemplar per uniclass"

	showingAllInstances _ showingAllInstances not.
	self presenter reinvigorateAllScriptsTool: self! !

!AllScriptsTool methodsFor: 'toggles' stamp: 'sw 11/14/2001 00:32'!
toggleWhetherShowingOnlyActiveScripts
	"Toggle whether the receiver is showing only active scripts"

	showingOnlyActiveScripts _ showingOnlyActiveScripts not.
	self presenter reinvigorateAllScriptsTool: self! !

!AllScriptsTool methodsFor: 'toggles' stamp: 'sw 11/14/2001 00:32'!
toggleWhetherShowingOnlyTopControls
	"Toggle whether the receiver is showing only the stop/step/go line or the full whammy"

	| aCenter |
	showingOnlyTopControls _ self showingOnlyTopControls not.
	aCenter _ self center x.
	self showingOnlyTopControls
		ifTrue:
			[self removeAllButFirstSubmorph]
		ifFalse:
			[self addSecondLineOfControls.
			self presenter reinvigorateAllScriptsTool: self].
	WorldState addDeferredUIMessage:
		[self center: (aCenter @ self center y)]
	! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AllScriptsTool class
	instanceVariableNames: ''!

!AllScriptsTool class methodsFor: 'instance creation' stamp: 'sw 6/12/2001 11:52'!
allScriptsToolForActiveWorld
	"Launch an AllScriptsTool to view scripts of the active world"

	| aTool |
	aTool _ self newColumn.
	aTool initializeFor: ActiveWorld presenter.
	^ aTool! !

!AllScriptsTool class methodsFor: 'instance creation' stamp: 'sw 1/30/2001 23:06'!
launchAllScriptsToolFor: aPresenter
	"Launch an AllScriptsTool to view scripts of the given presenter"

	| aTool |
	aTool _ self newColumn.
	aTool initializeFor: aPresenter.
	self currentHand attachMorph: aTool.
	aPresenter associatedMorph world startSteppingSubmorphsOf: aTool
! !


!AllScriptsTool class methodsFor: 'parts bin' stamp: 'tak 7/25/2007 00:03'!
descriptionForPartsBin
	"Answer a description for use in parts bins"

	^ self partName: 	'All Scripts' translatedNoop
		categories:		{'Scripting' translatedNoop}
		documentation:	'A tool allowing you to monitor and change the status of all scripts in your project' translatedNoop! !


!AllScriptsTool class methodsFor: 'printing' stamp: 'sw 11/13/2001 19:44'!
defaultNameStemForInstances
	"Answer the default name stem for new instances of this class"

	^ 'All Scripts'! !


!AllScriptsTool class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:28'!
initialize

	self registerInFlapsRegistry.	! !

!AllScriptsTool class methodsFor: 'class initialization' stamp: 'KR 8/12/2007 10:43'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: {#AllScriptsTool. #allScriptsToolForActiveWorld.	'All Scripts' translatedNoop. 'A tool that lets you see and control all the running scripts in your project' translatedNoop}
						forFlapNamed: 'PlugIn Supplies'.
						cl registerQuad: {#AllScriptsTool. #allScriptsToolForActiveWorld. 'All Scripts' translatedNoop. 'A tool that lets you control all the running scripts in your world' translatedNoop}
						forFlapNamed: 'Scripting'.
						cl registerQuad: {#AllScriptsTool. #allScriptsToolForActiveWorld. 'All Scripts' translatedNoop. 'A tool that lets you see and control all the running scripts in your project' translatedNoop}
						forFlapNamed: 'Widgets']! !

!AllScriptsTool class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:30'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self] ! !
ColorMappingCanvas subclass: #AlphaBlendingCanvas
	instanceVariableNames: 'alpha'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!

!AlphaBlendingCanvas methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:24'!
alpha
	^alpha! !

!AlphaBlendingCanvas methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:24'!
alpha: newAlpha
	alpha _ newAlpha.! !


!AlphaBlendingCanvas methodsFor: 'initialization' stamp: 'ar 8/8/2001 14:18'!
on: aCanvas
	myCanvas _ aCanvas.
	alpha _ 1.0.! !


!AlphaBlendingCanvas methodsFor: 'private' stamp: 'bf 10/28/2003 15:46'!
image: aForm at: aPoint sourceRect: sourceRect rule: rule
	"Draw the given form. For the 'paint' combination rule use stenciling otherwise simply fill the source rectangle."
	rule = Form paint ifTrue:[
		^myCanvas
			image: aForm
			at: aPoint
			sourceRect: sourceRect
			rule: Form paintAlpha
			alpha: alpha.
	].
	rule = Form over ifTrue:[
		^myCanvas
			image: aForm
			at: aPoint
			sourceRect: sourceRect
			rule: Form blendAlpha
			alpha: alpha.
	].! !

!AlphaBlendingCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:23'!
mapColor: aColor
	aColor isColor ifFalse:[^aColor]. "Should not happen but who knows..."
	aColor isTransparent ifTrue:[^aColor].
	aColor isOpaque ifTrue:[^aColor alpha: alpha].
	^aColor alpha: (aColor alpha * alpha)! !
AbstractScoreEvent subclass: #AmbientEvent
	instanceVariableNames: 'morph target selector arguments'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!

!AmbientEvent methodsFor: 'as yet unclassified' stamp: 'di 8/3/1998 21:27'!
morph 
	^ morph! !

!AmbientEvent methodsFor: 'as yet unclassified' stamp: 'di 8/3/1998 20:09'!
morph: m
	morph _ m! !

!AmbientEvent methodsFor: 'as yet unclassified' stamp: 'di 10/21/2000 13:18'!
occurAtTime: ticks inScorePlayer: player atIndex: index inEventTrack: track secsPerTick: secsPerTick
	(target == nil or: [selector == nil]) ifTrue:
		[morph ifNil: [^ self].
		^ morph encounteredAtTime: ticks inScorePlayer: player atIndex: index
				inEventTrack: track secsPerTick: secsPerTick].
	target perform: selector withArguments: arguments! !

!AmbientEvent methodsFor: 'as yet unclassified' stamp: 'di 8/3/1998 20:08'!
target: t selector: s arguments: a
	target _ t.
	selector _ s.
	arguments _ a.
! !
Object subclass: #Analyzer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-KCP'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Analyzer class
	instanceVariableNames: ''!

!Analyzer class methodsFor: 'dependencies' stamp: 'md 10/29/2003 23:40'!
dependenciesForClass: aClass 
	| r |
	r := Set new.
	aClass methodDict values
		do: [:cm | (cm literals
				select: [:l | l isKindOf: LookupKey]) 
				do: [:ll | ll key
						ifNotNil: [r add: ll key]]].
	^ r! !

!Analyzer class methodsFor: 'dependencies' stamp: 'md 10/29/2003 23:40'!
externalReference
	^ self ! !

!Analyzer class methodsFor: 'dependencies' stamp: 'md 10/29/2003 23:40'!
externalReferenceOf: aCollectionOfClass 
	| r |
	r := Set new.
	aCollectionOfClass
		do: [:cls | r
				addAll: (self dependenciesForClass: cls)].
	aCollectionOfClass 
		do: [:clss | r
				remove: clss name
				ifAbsent: []].
	^ r! !


!Analyzer class methodsFor: 'methods' stamp: 'md 10/29/2003 23:39'!
doesClass: cls define: aSelector 
	^ cls methodDict includesKey: aSelector ! !

!Analyzer class methodsFor: 'methods' stamp: 'ar 4/10/2005 22:15'!
methodsCalledAndCalleeForClass: aClass 
	| r |
	r := Set new.
	aClass methodDict
		associationsDo: [:assoc | (assoc value literals
				select: [:l | l isSymbol])
				do: [:ll | r 
						add: (Array with: assoc key with: ll)]].
	^ r! !

!Analyzer class methodsFor: 'methods' stamp: 'ar 4/10/2005 22:15'!
methodsCalledForClass: aClass 
	| r |
	r := Set new.
	aClass methodDict values 
		do: [:cm | (cm literals
				select: [:l | l isSymbol])
				do: [:ll | r add: ll]].
	^ r! !

!Analyzer class methodsFor: 'methods' stamp: 'md 10/29/2003 23:39'!
methodsDefinedForClass: aClass 
	^ aClass methodDict keys ! !

!Analyzer class methodsFor: 'methods' stamp: 'md 10/29/2003 23:40'!
methodsIn: cls callingMethodsDefinedIn: classes 
	"Give collection matching (m1, m2) where: 
	
		- m1 is defined in C 
	
		- m2 is defined in classes 
	
		- m2 called in m1 of C, 

		- and m2 not defined in C"
	
	"We made the following assumption: If a method foo is in defined in cls  
	and in classes, then if cls call foo, then it calls its own"

	| methodsCalled allMethodsDefined ans |
	methodsCalled := self methodsCalledAndCalleeForClass: cls.
	allMethodsDefined := Set new.
	classes
		do: [:clss | allMethodsDefined
				addAll: (self methodsDefinedForClass: clss)].
	ans := methodsCalled
				select: [:calleeCalled | (self doesClass: cls define: calleeCalled second) not
						and: [allMethodsDefined includes: calleeCalled second]].
	^ ans! !

!Analyzer class methodsFor: 'methods' stamp: 'md 10/29/2003 23:40'!
referingMethodsDefinedInSubclasses: aClass 
	| r |
	r := self methodsCalledForClass: aClass. 
	subclasses := aClass allSubclasses.
	subclasses remove: aClass! !


!Analyzer class methodsFor: 'examples' stamp: 'md 10/29/2003 23:39'!
example1
	"self example1"
	Analyzer externalReferenceOf: (#(#Object #Behavior #ClassDescription #Class )
			collect: [:clsname | Smalltalk at: clsname]) inspect ! !

!Analyzer class methodsFor: 'examples' stamp: 'md 10/29/2003 23:39'!
example2
	"self example2"
	(Analyzer 
		externalReferenceOf: (#(#Behavior #ClassDescription #Class )
				collect: [:clsname | Smalltalk at: clsname])) inspect! !

!Analyzer class methodsFor: 'examples' stamp: 'md 10/29/2003 23:39'!
example3
	"self example3"
	(((Analyzer
		externalReferenceOf: (#(#Behavior #ClassDescription #Class )
				collect: [:clsname | Smalltalk at: clsname]))
		select: [:clsName | (Smalltalk includesKey: clsName) 
				and: [(Smalltalk at: clsName)
						isKindOf: Class]])
		select: [:clssName | ((Smalltalk at: clssName) category asString beginsWith: 'Kernel') not]) inspect! !

!Analyzer class methodsFor: 'examples' stamp: 'md 10/29/2003 23:39'!
example4 
	"self example4"
	(((Analyzer
		externalReferenceOf: (#(#Object #Behavior #ClassDescription #Class )
				collect: [:clsname | Smalltalk at: clsname]))
		select: [:clsName | (Smalltalk includesKey: clsName)
				and: [(Smalltalk at: clsName)
						isKindOf: Class]])
		select: [:clssName | ((Smalltalk at: clssName) category asString beginsWith: 'Kernel') not]) inspect! !

!Analyzer class methodsFor: 'examples' stamp: 'md 10/29/2003 23:39'!
example5
	"self example5"
	| classes | 
	classes := #(#ClassBuilder #ClassDescription #Class )
				collect: [:clsname | Smalltalk at: clsname].
	(Analyzer methodsIn: Behavior callingMethodsDefinedIn: classes) inspect! !
TestCase subclass: #AnalyzerTest
	instanceVariableNames: 'classesCreated'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-KCP'!

!AnalyzerTest methodsFor: 'utility' stamp: 'ab 3/8/2003 13:55'!
createClass: aClassname
	^ self createClass: aClassname superclass: Object 
! !

!AnalyzerTest methodsFor: 'utility' stamp: 'md 10/29/2003 23:42'!
createClass: aClassname superclass: aClass 
	| r |
	r _ aClass
		subclass: aClassname
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Tests-KCP'.
	classesCreated add: r.
	^ r! !

!AnalyzerTest methodsFor: 'utility' stamp: 'md 10/29/2003 23:41'!
removeClassIfExists: aClassname 
	Smalltalk
		at: aClassname
		ifPresent: [:cls | cls removeFromSystem] ! !

!AnalyzerTest methodsFor: 'utility' stamp: 'rw 5/12/2003 11:56'!
removeClassNamedIfExists: aClassname

	Smalltalk at: aClassname ifPresent: [:cls| cls removeFromSystem].
	Smalltalk at: aClassname ifPresent: [:clss| self error: 'Error !!!!']! !


!AnalyzerTest methodsFor: 'running' stamp: 'ab 3/8/2003 13:54'!
setUp
	classesCreated _ OrderedCollection new! !

!AnalyzerTest methodsFor: 'running' stamp: 'sd 5/23/2003 14:51'!
tearDown

	| name |
	classesCreated
		do: [:cls | 
			name _ cls name.
			self removeClassNamedIfExists: name.
			ChangeSet current removeClassChanges: name].
	classesCreated _ nil! !


!AnalyzerTest methodsFor: 'dependencies' stamp: 'ab 3/8/2003 14:04'!
testDependenciesForClass
	| cls r |
	cls _ self createClass: #MyClass.
	"-------"
	cls compile: 'foo ^ Object'.
	cls compile: 'bar Transcript show: ''blah blah'''.
	cls compile: 'zork OrderedCollection new'.
	"-------"
	r _ Analyzer dependenciesForClass: cls.
	self assert: r size = 3.
	self
		assert: (r includesAllOf: #(#Object #Transcript #OrderedCollection )).
! !

!AnalyzerTest methodsFor: 'dependencies' stamp: 'ab 3/8/2003 14:04'!
testExternalReferenceOf
	| r cls1 cls2 cls3 |
	cls1 _ self createClass: #MyClass1.
	cls2 _ self createClass: #MyClass2.
	cls3 _ self createClass: #MyClass3.
	"-------"
	cls1 compile: 'foo ^ MyClass2'.
	cls1 compile: 'bar MyClass1 show: ''blah blah'''.
	cls1 compile: 'zork OrderedCollection new'.
	cls1 compile: 'baz Morph new openInWorld'.
	"-------"
	cls2 compile: 'foo ^ Object'.
	cls2 compile: 'bar Transcript show: ''blah blah'''.
	cls2 compile: 'zork OrderedCollection new'.
	"-------"
	cls3 compile: 'foo ^ Object'.
	cls3 compile: 'bar Transcript show: ''blah blah'''.
	cls3 compile: 'zork MyClass3 new'.
	"-------"
	r _ Analyzer
				externalReferenceOf: (#(#MyClass1 #MyClass2 #MyClass3 )
						collect: [:clsName | Smalltalk at: clsName]).
	self assert: r size = 4.
	self
		assert: (r includesAllOf: #(#Object #Transcript #OrderedCollection #Morph )).
! !


!AnalyzerTest methodsFor: 'methods' stamp: 'ab 3/8/2003 14:03'!
testMethodCallDefinedInSubclasses
	| cls1 cls2 r |
	cls1 _ self createClass: #MyClass1.
	cls2 _ self createClass: #MyClass2 superclass: cls1.
	"-------"
	cls1 compile: 'foo ^ self bar'.
	cls2 compile: 'bar ^ true'.
	"-------"
	self assert: cls2 new foo.
	r _ Analyzer
				methodsIn: cls1
				callingMethodsDefinedIn: (Array with: cls2).
	r _ r asOrderedCollection.
	self assert: r size = 1.
	self assert: r first size = 2.
	self assert: r first first == #foo.
	self assert: r first second == #bar.
! !

!AnalyzerTest methodsFor: 'methods' stamp: 'ab 3/8/2003 14:03'!
testMethodCallDefinedInSubclasses2
	| cls1 cls2 r cls3 cls4 |
	cls1 _ self createClass: #MyClass1.
	cls2 _ self createClass: #MyClass2 superclass: cls1.
	cls3 _ self createClass: #MyClass3.
	cls4 _ self createClass: #MyClass4 superclass: cls3.
	"-------"
	cls1 compile: 'foo ^ self f1; f2'.
	cls1 compile: 'bar ^ self f3; foo'.
	cls1 compile: 'zork ^ self bar; blah'.
	cls2 compile: 'f1 ^ true'.
	cls2 compile: 'f2 ^ true'.
	cls3 compile: 'f3 ^ true'.
	cls3 compile: 'foo ^ true'.
	cls4 compile: 'f3 ^ true'.
	cls4 compile: 'f4 ^ true'.
	cls4 compile: 'bleubleu ^ true'.
	cls4 compile: 'bouba ^ true'.
	"-------"
	r _ Analyzer
				methodsIn: cls1
				callingMethodsDefinedIn: (Array
						with: cls2
						with: cls3
						with: cls4).
	r _ r asOrderedCollection.
	self assert: r size = 3.
	self
		assert: (r includesAllOf: #(#(#foo #f1) #(#foo #f2) #(#bar #f3) )).
! !

!AnalyzerTest methodsFor: 'methods' stamp: 'ab 3/8/2003 14:03'!
testMethodsCalledAndCalleeForClass
	| cls r |
	cls _ self createClass: #MyClass.
	"-------"
	cls compile: 'foo ^ Object'.
	cls compile: 'bar Transcript show: ''blah blah'''.
	cls compile: 'zork OrderedCollection new'.
	cls compile: 'foobar Object new asMorph; beep'.
	"-------"
	r _ Analyzer methodsCalledAndCalleeForClass: cls.
	self assert: r size = 3.
	self
		assert: (r includesAllOf: #(#(#bar #show:) #(#foobar #asMorph) #(#foobar #asMorph) )).
! !

!AnalyzerTest methodsFor: 'methods' stamp: 'ab 3/8/2003 14:03'!
testMethodsCalledForClass
	| cls r |
	cls _ self createClass: #MyClass.
	"-------"
	cls compile: 'foo ^ Object'.
	cls compile: 'bar Transcript show: ''blah blah'''.
	cls compile: 'zork OrderedCollection new'.
	cls compile: 'foobar Object new asMorph; beep'.
	"-------"
	r _ Analyzer methodsCalledForClass: cls.
	self assert: r size = 3.
	self
		assert: (r includesAllOf: #(#beep #show: #asMorph )).
! !
GIFReadWriter subclass: #AnimatedGIFReadWriter
	instanceVariableNames: 'forms delays comments'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Files'!

!AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'bf 2/25/2005 11:11'!
allImages
	| body colorTable |
	stream class == ReadWriteStream ifFalse: [
		stream binary.
		self on: (ReadWriteStream with: (stream contentsOfEntireFile))].
	localColorTable _ nil.
	forms _ OrderedCollection new.
	delays _ OrderedCollection new.
	comments _ OrderedCollection new.
	self readHeader.
	[(body _ self readBody) == nil]
		whileFalse: [colorTable _ localColorTable
						ifNil: [colorPalette].
			transparentIndex
				ifNotNil: [transparentIndex + 1 > colorTable size
						ifTrue: [colorTable _ colorTable forceTo: transparentIndex + 1 paddingWith: Color white].
					colorTable at: transparentIndex + 1 put: Color transparent].
			body colors: colorTable.
			forms add: body.
			delays add: delay].
	^ forms! !

!AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'mir 11/19/2003 14:16'!
delays
	^ delays! !

!AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'mir 11/19/2003 14:16'!
forms
	^ forms! !


!AnimatedGIFReadWriter methodsFor: 'private-decoding' stamp: 'mir 11/19/2003 12:21'!
readBitData
	| form |
	form := super readBitData.
	form offset: offset.
	^form! !


!AnimatedGIFReadWriter methodsFor: 'private' stamp: 'mir 11/19/2003 12:25'!
comment: aString
	comments add: aString! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AnimatedGIFReadWriter class
	instanceVariableNames: ''!

!AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'mir 11/18/2003 17:00'!
formsFromFileNamed: fileName 
	| stream |
	stream _ FileStream readOnlyFileNamed: fileName.
	^ self formsFromStream: stream! !

!AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'mir 11/18/2003 17:00'!
formsFromStream: stream 
	| reader |
	reader _ self new on: stream reset.
	Cursor read
		showWhile: [reader allImages.
			reader close].
	^reader! !

!AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 6/12/2004 13:12'!
typicalFileExtensions
	"Answer a collection of file extensions (lowercase) which files that I can read might commonly have"
	^#('gif')! !

!AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'asm 12/11/2003 21:29'!
wantsToHandleGIFs
	^true! !
ImageMorph subclass: #AnimatedImageMorph
	instanceVariableNames: 'images delays stepTime nextTime imageIndex'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!
!AnimatedImageMorph commentStamp: '<historical>' prior: 0!
I am an ImageMorph that can hold more than one image. Each image has its own delay time.!


!AnimatedImageMorph methodsFor: 'stepping and presenter' stamp: 'sw 7/28/2007 23:49'!
step
	"Period action: animate the image."

	| d |
	images isEmpty ifTrue: [^ self].
		
	nextTime > Time millisecondClockValue
		ifTrue: [^self].
	self image: (images at: (imageIndex _ imageIndex \\ images size + 1)).
	self changed . 
	d _ (delays at: imageIndex) ifNil: [0].
	nextTime := Time millisecondClockValue + d! !

!AnimatedImageMorph methodsFor: 'stepping and presenter' stamp: 'mir 11/19/2003 13:40'!
stepTime
	^stepTime ifNil: [super stepTime]! !

!AnimatedImageMorph methodsFor: 'stepping and presenter' stamp: 'mir 11/19/2003 13:40'!
stepTime: anInteger
	stepTime _ anInteger! !

!AnimatedImageMorph methodsFor: 'stepping and presenter' stamp: 'asm 12/15/2003 19:44'!
wantsSteps
	^(images size > 1)
! !


!AnimatedImageMorph methodsFor: 'private' stamp: 'nk 2/15/2004 15:20'!
fromGIFFileNamed: fileName
	self fromReader: (AnimatedGIFReadWriter formsFromFileNamed: fileName)! !

!AnimatedImageMorph methodsFor: 'private' stamp: 'bf 2/25/2005 11:18'!
fromReader: reader
	images _ reader forms.
	delays _ reader delays.
	imageIndex _ 0.
	self image: (Form extent: images first extent depth: 32).
	self step! !

!AnimatedImageMorph methodsFor: 'private' stamp: 'nk 2/15/2004 15:20'!
fromStream: aStream
	self fromReader: (AnimatedGIFReadWriter formsFromStream: aStream)! !

!AnimatedImageMorph methodsFor: 'private' stamp: 'mir 11/19/2003 13:42'!
images
	^images! !

!AnimatedImageMorph methodsFor: 'private' stamp: 'bf 2/25/2005 11:09'!
initialize
	nextTime := Time millisecondClockValue.
	imageIndex := 1.
	stepTime := 10.
	super initialize! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AnimatedImageMorph class
	instanceVariableNames: ''!

!AnimatedImageMorph class methodsFor: 'instance creation' stamp: 'nk 2/15/2004 15:23'!
fromGIFFileNamed: fileName
	| reader |
	reader _ AnimatedGIFReadWriter formsFromFileNamed: fileName.
	^reader forms size = 1
		ifTrue: [ ImageMorph new image: reader forms first ]
		ifFalse: [ self new fromReader: reader ]! !

!AnimatedImageMorph class methodsFor: 'instance creation' stamp: 'nk 2/15/2004 15:27'!
fromStream: aStream
	| reader |
	reader _ AnimatedGIFReadWriter formsFromStream: aStream.
	^reader forms size = 1
		ifTrue: [ ImageMorph new image: reader forms first ]
		ifFalse: [ self new fromReader: reader ]! !

!AnimatedImageMorph class methodsFor: 'instance creation' stamp: 'nk 2/15/2004 16:57'!
openGIFInWindow: aStream
	^(self fromStream: aStream binary) openInWorld! !


!AnimatedImageMorph class methodsFor: 'class initialization' stamp: 'asm 12/11/2003 21:05'!
initialize
	"register the receiver in the global registries"
	self environment
		at: #FileList
		ifPresent: [:cl | cl registerFileReader: self]! !

!AnimatedImageMorph class methodsFor: 'class initialization' stamp: 'asm 12/11/2003 21:01'!
unload
	"Unload the receiver from global registries"
	self environment
		at: #FileList
		ifPresent: [:cl | cl unregisterFileReader: self]! !


!AnimatedImageMorph class methodsFor: 'fileIn/Out' stamp: 'nk 6/12/2004 13:11'!
fileReaderServicesForFile: fullName suffix: suffix

	^((AnimatedGIFReadWriter typicalFileExtensions asSet
		add: '*'; add: 'form'; yourself)
		includes: suffix)
		ifTrue: [ self services ]
		ifFalse: [#()]
! !

!AnimatedImageMorph class methodsFor: 'fileIn/Out' stamp: 'nk 4/29/2004 10:35'!
serviceOpenGIFInWindow
	"Answer a service for opening a gif graphic in a window"

	^ (SimpleServiceEntry 
		provider: self 
		label: 'open graphic in a window'
		selector: #openGIFInWindow:
		description: 'open a GIF graphic file in a window'
		buttonLabel: 'open')
		argumentGetter: [ :fileList | fileList readOnlyStream ]! !

!AnimatedImageMorph class methodsFor: 'fileIn/Out' stamp: 'yo 10/15/2006 02:07'!
services
	
	| a |
	a _ Array with: self serviceOpenGIFInWindow.

	Preferences eToyFriendly ifFalse: [
		a _ (Array with: Form serviceImageAsBackground with: Form serviceImageImports), a.
	].

	^ a.
! !
AbstractMediaEventMorph subclass: #AnonymousSoundMorph
	instanceVariableNames: 'sound interimName'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Interface'!
!AnonymousSoundMorph commentStamp: 'sw 10/19/2007 16:56' prior: 0!
Holds a free-standing sound, i.e. one not associated with the system's sound library.
Can be played by hitting Play button, and can stop its playing by hitting Stop.
Can be dropped into a piano roll or into an event roll
Can also be named and added to the system sound library, by hitting the save button.!


!AnonymousSoundMorph methodsFor: 'initialization' stamp: 'sw 10/19/2007 19:13'!
addButtonRow
	"Add the row of control buttons."

	| row button |
	row := AlignmentMorph newRow vResizing: #shrinkWrap;
				 color: Color transparent.
	row addVariableTransparentSpacer.
	button := SimpleButtonMorph new label: 'Play' translated font: ScriptingSystem fontForEToyButtons;
				 target: self;
				 actionSelector: #playSound.
	row addMorphBack: button.
	row addVariableTransparentSpacer.
	button := SimpleButtonMorph new label: 'Stop' translated font: ScriptingSystem fontForEToyButtons;
				 target: self;
				 actionSelector: #stopSound.
	row addMorphBack: button.
	row addVariableTransparentSpacer.

	button := SimpleButtonMorph new label: 'Save' translated font: ScriptingSystem fontForEToyButtons;
				 target: self;
				 actionSelector: #addToSoundLibrary .
	row addMorphBack: button.
	row addVariableTransparentSpacer.
	self addMorphBack: row! !

!AnonymousSoundMorph methodsFor: 'initialization' stamp: 'sw 7/12/2007 02:56  <  dgd 2/14/2003 22:31'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color lightGreen! !

!AnonymousSoundMorph methodsFor: 'initialization' stamp: 'sw 10/19/2007 14:50'!
initialize
	"initialize the state of the receiver"

	super initialize.
	self height: 18.

	self balloonTextSelector: #soundMorphHelpString.
	self on: #doubleClick send: #playSound to: self.
	self on: #mouseMove send: #openInHand to: self.
	self on: #click send: #stopSound to: self.

	interimName := SampledSound unusedSoundNameLike: 'Unnamed' translated! !

!AnonymousSoundMorph methodsFor: 'initialization' stamp: 'sw 7/12/2007 03:20'!
soundMorphHelpString
	"Answer a string represnting the ballon text for the receiver."

	^ 'Holds a recorded sound of duration ' translated, (sound duration printShowingDecimalPlaces: 3),' seconds.
Double-click to hear the sound.  "add to sound library" available in halo menu.  Also suitable for dropping into a piano-roll or into an event-roll' translated! !

!AnonymousSoundMorph methodsFor: 'initialization' stamp: 'sw 10/19/2007 16:57'!
sound: aSampledSound interimName: anInterimName
	"Establish the sound object and an interim name."

	| aStringMorph |
	self removeAllMorphs.
	self hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	borderWidth _ 2.
	self listDirection: #topToBottom.
	sound := aSampledSound.
	interimName := anInterimName.

	aStringMorph := StringMorph contents: interimName font: ScriptingSystem fontForEToyButtons.
	self addMorphBack: aStringMorph.
	self addButtonRow.

	self balloonTextSelector: #soundMorphHelpString.
	self setNameTo: interimName! !


!AnonymousSoundMorph methodsFor: 'piano roll' stamp: 'sw 7/24/2007 14:55'!
addMorphsTo: morphList pianoRoll: pianoRoll eventTime: t betweenTime: leftTime and: rightTime
	"Custom piano-roll processing.  Consult my sender for more info."

	| startX lengthInTicks endX |
	startTimeInScore > rightTime ifTrue: [^ self].  
	lengthInTicks _ pianoRoll scorePlayer ticksForMSecs: sound duration * 1000.0.
	startTimeInScore + lengthInTicks < leftTime ifTrue: [^ self].
	startX _ pianoRoll xForTime: startTimeInScore.
	endX _ pianoRoll xForTime: startTimeInScore + lengthInTicks.
	morphList add: 
		(self left: startX; width: endX - startX).

! !

!AnonymousSoundMorph methodsFor: 'piano roll' stamp: 'sw 7/12/2007 02:56  <  RAA 12/7/2000 12:29'!
encounteredAtTime: ticks inScorePlayer: scorePlayer atIndex: index inEventTrack: track secsPerTick: secsPerTick

	"hack... since we are called from within the SoundPlayer loop, the Semaphore will
	block attempts to play directly from here"
	WorldState addDeferredUIMessage: [sound play].! !

!AnonymousSoundMorph methodsFor: 'piano roll' stamp: 'sw 10/19/2007 16:30'!
justDroppedIntoPianoRoll: newOwner event: evt
	"The receiver was just dropped into a piano roll... respond accordingly."

	| startX lengthInTicks endX |
	super justDroppedIntoPianoRoll: newOwner event: evt.
	submorphs size > 1 ifTrue: [submorphs last delete].
	self hResizing: #rigid; clipSubmorphs: true.

	startTimeInScore _ newOwner timeForX: self left.
	lengthInTicks _ newOwner scorePlayer ticksForMSecs: sound duration * 1000.0.
	endTimeInScore _ startTimeInScore + lengthInTicks.

	endTimeInScore > newOwner scorePlayer durationInTicks ifTrue:
		[newOwner scorePlayer updateDuration].

	startX _ newOwner xForTime: startTimeInScore.
	endX _ newOwner xForTime: endTimeInScore.
	self width: endX - startX! !

!AnonymousSoundMorph methodsFor: 'piano roll' stamp: 'sw 10/19/2007 16:31'!
justDroppedInto: aMorph event: evt
	"The receiver was just dropped into some container... respond accordingly."

	super justDroppedInto: aMorph event: evt.
	(aMorph isKindOf: PianoRollScoreMorph ) ifTrue: [^ self].
	submorphs size < 2 ifTrue:
		[self sound: sound interimName: interimName]! !


!AnonymousSoundMorph methodsFor: 'event roll' stamp: 'sw 7/12/2007 02:56  <  sw 12/24/2006 04:24'!
putEventsOnto: aStream
	"Write all of the events represented by the receiver in its current state onto the given stream."

	| aNewEvent |
	aNewEvent :=  MediaPlayEvent new.
	aNewEvent setType: #startSound argument: self sound hand: nil stamp: (self eventRoll timeStampForCurrentPositionOf: self).
	aStream nextPut: aNewEvent! !

!AnonymousSoundMorph methodsFor: 'event roll' stamp: 'sw 7/12/2007 02:56  <  sw 12/20/2006 03:49'!
suitableForDroppingIntoEventRoll
	"Answer whether the receiver is suitable for dropping into an Event Roll."

	^ true! !


!AnonymousSoundMorph methodsFor: 'caching' stamp: 'sw 7/24/2007 14:54'!
releaseCachedState
	"If the sound is not currently compressed, compress it with the GSM codec"

	super releaseCachedState.
	sound isCompressed
		ifFalse: [sound _ sound compressWith: GSMCodec].
! !


!AnonymousSoundMorph methodsFor: 'accessing' stamp: 'sw 7/12/2007 02:56  <  sw 12/20/2006 03:51'!
sound
	"Answer the sound."

	^ sound! !


!AnonymousSoundMorph methodsFor: 'menu' stamp: 'sw 10/19/2007 15:10'!
addCustomMenuItems: aMenu hand: aHandMorph
	"Add morph-specific items to the given menu which was invoked by the given hand.  This method provides is invoked both from the halo-menu and from the control-menu regimes."

	super addCustomMenuItems: aMenu hand: aHandMorph.

	aMenu addTranslatedList: #(
		-
		('wave editor' openWaveEditorOnSound 'open a wave-editor tool with this sound as its iniital sound')) translatedNoop! !

!AnonymousSoundMorph methodsFor: 'menu' stamp: 'sw 10/19/2007 16:34'!
addToSoundLibrary
	"Add the receiver's sound to the library, and hand the user a tile representing it."

	| aName tile |
	aName := FillInTheBlank request: 'kindly give the sound a name: ' initialAnswer: (interimName ifNil: ['']).
	aName isEmptyOrNil ifTrue: [^ self].

	aName := SampledSound unusedSoundNameLike:  aName.

	SampledSound
			addLibrarySoundNamed: aName
			samples: sound samples
			samplingRate: sound samplingRate.
	tile _ SoundTile new literal: aName.
	tile bounds: tile fullBounds.
	tile center: self fullBoundsInWorld center.
	(ScriptingTileHolder around: tile) center:  self fullBoundsInWorld center;
		openInWorld.
	
	self delete! !

!AnonymousSoundMorph methodsFor: 'menu' stamp: 'sw 10/19/2007 15:11'!
openWaveEditorOnSound
	"Open a wave-editor tool on the receiver's sound"

	WaveEditor openOn: sound samples! !

!AnonymousSoundMorph methodsFor: 'menu' stamp: 'sw 7/12/2007 02:56  <  sw 7/12/2007 00:29'!
playSound
	"Play the receiver's sound."

	sound play! !

!AnonymousSoundMorph methodsFor: 'menu' stamp: 'sw 10/18/2007 22:15'!
stopPlayingSound
	"If the receiver's sound is playing, stop it."

	sound pause! !

!AnonymousSoundMorph methodsFor: 'menu' stamp: 'sw 7/12/2007 03:22'!
stopSound
	"Stop the receiver's sound from playing."

	sound pause! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AnonymousSoundMorph class
	instanceVariableNames: ''!

!AnonymousSoundMorph class methodsFor: 'fileIn/Out' stamp: 'sw 10/19/2007 15:18'!
fileReaderServicesForFile: fullName suffix: suffix 
	"Answer the file services associated with given file"

	^ (self registeredAudioFileSuffixes includes: suffix)
		ifTrue: [self services]
		ifFalse: [#()]! !

!AnonymousSoundMorph class methodsFor: 'fileIn/Out' stamp: 'sw 10/19/2007 19:27'!
fromFileName: fullName
	"Create an instance of the receiver from the given file path."
	
	| newPlayer aSound ext aName |
	newPlayer _ self new initialize.
	('*aif' match: fullName) 
		ifTrue: [aSound := SampledSound fromAIFFfileNamed: fullName].
	('*wav' match: fullName) 
		ifTrue: [aSound := SampledSound fromWaveFileNamed: fullName].
	newPlayer := self new.

	ext := FileDirectory extensionFor: fullName.
	aName :=  (FileDirectory on: fullName) pathParts last.
	ext size > 0 ifTrue:
		[aName := aName copyFrom: 1 to: (aName size - (ext size + 1))].
	
	newPlayer sound: aSound interimName: aName.

	newPlayer openInWorld! !


!AnonymousSoundMorph class methodsFor: 'file suffixes' stamp: 'sw 10/19/2007 15:17'!
registeredAudioFileSuffixes
    "Answer the file extensions for which the receiver registers audio services with FileList."
     "AnonymousSoundMorph registeredAudioFileSuffixes"

     ^ { 'aif'.  'wav'}! !
Object subclass: #AnotherDummyClassForTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-KCP'!

!AnotherDummyClassForTest methodsFor: 'as yet unclassified' stamp: 'sd 4/15/2003 21:19'!
callingAThirdMethod

	self inform: ';lkl;'.
	self zoulouSymbol! !

!AnotherDummyClassForTest methodsFor: 'as yet unclassified' stamp: 'sd 4/15/2003 20:49'!
zoulouSymbol

	self callingAThirdMethod! !
StarSqueakTurtle subclass: #AntColonyTurtle
	instanceVariableNames: 'isCarryingFood pheromoneDropSize'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'StarSqueak-Worlds'!

!AntColonyTurtle methodsFor: 'variables' stamp: 'jm 2/26/2000 10:24'!
isCarryingFood

	^ isCarryingFood
! !

!AntColonyTurtle methodsFor: 'variables' stamp: 'jm 2/26/2000 10:25'!
isCarryingFood: aBoolean

	isCarryingFood _ aBoolean.
! !

!AntColonyTurtle methodsFor: 'variables' stamp: 'jm 2/26/2000 10:24'!
pheromoneDropSize

	^ pheromoneDropSize
! !

!AntColonyTurtle methodsFor: 'variables' stamp: 'jm 2/26/2000 10:25'!
pheromoneDropSize: aNumber

	pheromoneDropSize _ aNumber.
! !


!AntColonyTurtle methodsFor: 'demons' stamp: 'jm 3/8/2001 14:26'!
dropFoodInNest

	(isCarryingFood and: [(self get: 'isNest') > 0]) ifTrue: [
		self color: Color black.
		isCarryingFood _ false.
		"turn around and go forward to try to pick up pheromone trail"
		self turnRight: 180.
		self forward: 3].
! !

!AntColonyTurtle methodsFor: 'demons' stamp: 'jm 3/8/2001 14:22'!
pickUpFood

	| newFood |
	(isCarryingFood not and: [(self get: 'food') > 0]) ifTrue: [
		newFood _ (self get: 'food') - 1.
		self set: 'food' to: newFood.
		newFood = 0 ifTrue: [self patchColor: world backgroundColor].
		isCarryingFood _ true.
		pheromoneDropSize _ 800.
		self color: Color red.

		"drop a blob of pheromone on the side of the food farthest from nest"
		self turnTowardsStrongest: 'nestScent'.
		self turnRight: 180.
		self forward: 4.
		self increment: 'pheromone' by: 5000].
! !

!AntColonyTurtle methodsFor: 'demons' stamp: 'jm 2/7/2001 19:20'!
returnToNest

	isCarryingFood ifTrue: [
		"decrease size of pheromone drops to create a gradient back to food"
		pheromoneDropSize > 0 ifTrue: [
			self increment: 'pheromone' by: pheromoneDropSize.
			pheromoneDropSize _ pheromoneDropSize - 20].
		self turnTowardsStrongest: 'nestScent'.
		self forward: 1].
! !

!AntColonyTurtle methodsFor: 'demons' stamp: 'jm 2/7/2001 08:12'!
searchForFood
	"If you smell pheromone, go towards the strongest smell. Otherwise, wander aimlessly."

	isCarryingFood ifFalse: [
		((self get: 'pheromone') > 1)
			ifTrue: [self turnTowardsStrongest: 'pheromone']
			ifFalse: [
				self turnRight: (self random: 40).
				self turnLeft: (self random: 40)].
		self forward: 1].
! !
Object subclass: #AppRegistry
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Applications'!
!AppRegistry commentStamp: 'ads 4/2/2003 15:30' prior: 0!
AppRegistry is a simple little class, not much more than a wrapper around a collection. It's intended to help break dependencies between packages. For example, if you'd like to be able to send e-mail, you could use the bare-bones MailComposition class, or you could use the full-blown Celeste e-mail client. Instead of choosing one or the other, you can call "MailSender default" (where MailSender is a subclass of AppRegistry), and thus avoid creating a hard-coded dependency on either of the two mail senders.

This will only really be useful, of course, for applications that have a very simple, general, well-defined interface. Most of the time, you're probably better off just marking your package as being dependent on a specific other package, and avoiding the hassle of this whole AppRegistry thing. But for simple things like e-mail senders or web browsers, it might be useful.
!


!AppRegistry methodsFor: 'as yet unclassified' stamp: 'ads 4/2/2003 15:04'!
seeClassSide
	"All the code for AppRegistry is on the class side."! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AppRegistry class
	instanceVariableNames: 'registeredClasses default'!

!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 3/29/2003 13:36'!
appName
	"Defaults to the class name, which is probably good enough, but you could override this in subclasses if you want to."
	^ self name! !

!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'md 12/1/2004 23:58'!
askForDefault
	| menu |
	self registeredClasses isEmpty ifTrue:
		[self inform: 'There are no ', self appName, ' applications registered.'.
		^ default _ nil].
	self registeredClasses size = 1 ifTrue:
		[^ default _ self registeredClasses anyOne].
	
	menu _ CustomMenu new.
	self registeredClasses do: [:c | menu add: c name printString action: c].
	default _  menu startUpWithCaption: 'Which ', self appName, ' would you prefer?'.
	default ifNil: [default := self registeredClasses first].
	^default.! !

!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 3/29/2003 13:11'!
default
	^ default ifNil: [self askForDefault]! !

!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'nk 3/9/2004 12:33'!
default: aClassOrNil
	"Sets my default to aClassOrNil. 
	Answers the old default."
	| oldDefault |
	oldDefault := default.
	aClassOrNil ifNotNil: [ self register: aClassOrNil ].
	default := aClassOrNil.
	^ oldDefault! !

!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'nk 3/9/2004 12:35'!
defaultOrNil
	^ default! !

!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 4/2/2003 15:25'!
register: aProviderClass
	(self registeredClasses includes: aProviderClass) ifFalse:
		[default _ nil.  "so it'll ask for a new default, since if you're registering a new app you probably want to use it"
		self registeredClasses add: aProviderClass].! !

!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 3/29/2003 13:01'!
registeredClasses
	^ registeredClasses ifNil: [registeredClasses _ OrderedCollection new]! !

!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 3/29/2003 13:03'!
unregister: aProviderClass
	(default = aProviderClass) ifTrue: [default _ nil].
	self registeredClasses remove: aProviderClass ifAbsent: [].! !
ObjectSocket subclass: #ArbitraryObjectSocket
	instanceVariableNames: 'encodingOfLastEncodedObject lastEncodedObject'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Network-ObjectSocket'!
!ArbitraryObjectSocket commentStamp: '<historical>' prior: 0!
A network connection that passes objects instead of bytes.  The objects are encoded with SmartRefStreams.

Of course, one can send Arrays of Strings if one is unsure of what exactly SmartRefStream's are going to do.
!


!ArbitraryObjectSocket methodsFor: 'private' stamp: 'ls 4/25/2000 19:18'!
encodeObject: object  into: buffer  startingAt: startIndex
	"encode the given object into the given buffer"
	| encoded |
	encoded := self smartRefStreamEncode: object.
	buffer putInteger32: encoded size at: startIndex.
	buffer replaceFrom: startIndex+4 to: startIndex+4+(encoded size)-1 with: encoded.
! !

!ArbitraryObjectSocket methodsFor: 'private' stamp: 'ls 4/25/2000 19:19'!
nextObjectLength
	"read the next object length from inBuf.  Returns nil if less than 4 bytes are available in inBuf"
	self inBufSize < 4 ifTrue: [ ^nil ].

	^inBuf getInteger32: inBufIndex! !

!ArbitraryObjectSocket methodsFor: 'private' stamp: 'mir 5/15/2003 15:35'!
processInput
	"recieve some data"
	| inObjectData |

	"read as much data as possible"
	self addToInBuf: socket receiveAvailableData.


	"decode as many objects as possible"
	[self nextObjectLength ~~ nil and: [ self nextObjectLength <= (self inBufSize + 4) ]] whileTrue: [
		"a new object has arrived"
		inObjectData _ inBuf copyFrom: (inBufIndex + 4) to: (inBufIndex + 3 + self nextObjectLength).
		inBufIndex := inBufIndex + 4 + self nextObjectLength.

		inObjects addLast: (RWBinaryOrTextStream with: inObjectData) reset fileInObjectAndCode ].

	self shrinkInBuf.! !

!ArbitraryObjectSocket methodsFor: 'private' stamp: 'ls 4/25/2000 19:33'!
smartRefStreamEncode: anObject
	| encodingStream |
	"encode an object using SmartRefStream"

	anObject == lastEncodedObject ifTrue: [
		^encodingOfLastEncodedObject ].


	encodingStream := RWBinaryOrTextStream on: ''.
	encodingStream reset.
	(SmartRefStream on: encodingStream) nextPut: anObject.
	
	lastEncodedObject := anObject.
	encodingOfLastEncodedObject := encodingStream contents.

	^encodingOfLastEncodedObject! !

!ArbitraryObjectSocket methodsFor: 'private' stamp: 'ls 4/25/2000 19:36'!
spaceToEncode: anObject
	"return the number of characters needed to encode the given object"
	^ 4 + (self smartRefStreamEncode: anObject) size! !
Path subclass: #Arc
	instanceVariableNames: 'quadrant radius center'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Paths'!
!Arc commentStamp: '<historical>' prior: 0!
Arcs are an unusual implementation of splines due to Ted Kaehler.  Imagine two lines that meet at a corner. Now imagine two moving points; one moves from the corner to the end on one line, the other moves from the end of the other line in to the corner.  Now imagine a series of lines drawn between those moving points at each step along the way (they form a sort of spider web pattern).  By connecting segments of the intersecting lines, a smooth curve is achieved that is tangent to both of the original lines.  Voila.!


!Arc methodsFor: 'accessing'!
center
	"Answer the point at the center of the receiver."

	^center! !

!Arc methodsFor: 'accessing'!
center: aPoint 
	"Set aPoint to be the receiver's center."

	center _ aPoint! !

!Arc methodsFor: 'accessing'!
center: aPoint radius: anInteger 
	"The receiver is defined by a point at the center and a radius. The 
	quadrant is not reset."

	center _ aPoint.
	radius _ anInteger! !

!Arc methodsFor: 'accessing'!
center: aPoint radius: anInteger quadrant: section 
	"Set the receiver's quadrant to be the argument, section. The size of the 
	receiver is defined by the center and its radius."

	center _ aPoint.
	radius _ anInteger.
	quadrant _ section! !

!Arc methodsFor: 'accessing'!
quadrant
	"Answer the part of the circle represented by the receiver."
	^quadrant! !

!Arc methodsFor: 'accessing'!
quadrant: section 
	"Set the part of the circle represented by the receiver to be the argument, 
	section."

	quadrant _ section! !

!Arc methodsFor: 'accessing'!
radius
	"Answer the receiver's radius."

	^radius! !

!Arc methodsFor: 'accessing'!
radius: anInteger 
	"Set the receiver's radius to be the argument, anInteger."

	radius _ anInteger! !


!Arc methodsFor: 'display box access'!
computeBoundingBox
	| aRectangle aPoint |
	aRectangle _ center - radius + form offset extent: form extent + (radius * 2) asPoint.
	aPoint _ center + form extent.
	quadrant = 1 ifTrue: [^ aRectangle encompass: center x @ aPoint y].
	quadrant = 2 ifTrue: [^ aRectangle encompass: aPoint x @ aPoint y].
	quadrant = 3 ifTrue: [^ aRectangle encompass: aPoint x @ center y].
	quadrant = 4 ifTrue: [^ aRectangle encompass: center x @ center y]! !


!Arc methodsFor: 'displaying'!
displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm

	| nSegments line angle sin cos xn yn xn1 yn1 |
	nSegments _ 12.0.
	line _ Line new.
	line form: self form.
	angle _ 90.0 / nSegments.
	sin _ (angle * (2 * Float pi / 360.0)) sin.
	cos _ (angle * (2 * Float pi / 360.0)) cos.
	quadrant = 1
		ifTrue: 
			[xn _ radius asFloat.
			yn _ 0.0].
	quadrant = 2
		ifTrue: 
			[xn _ 0.0.
			yn _ 0.0 - radius asFloat].
	quadrant = 3
		ifTrue: 
			[xn _ 0.0 - radius asFloat.
			yn _ 0.0].
	quadrant = 4
		ifTrue: 
			[xn _ 0.0.
			yn _ radius asFloat].
	nSegments asInteger
		timesRepeat: 
			[xn1 _ xn * cos + (yn * sin).
			yn1 _ yn * cos - (xn * sin).
			line beginPoint: center + (xn asInteger @ yn asInteger).
			line endPoint: center + (xn1 asInteger @ yn1 asInteger).
			line
				displayOn: aDisplayMedium
				at: aPoint
				clippingBox: clipRect
				rule: anInteger
				fillColor: aForm.
			xn _ xn1.
			yn _ yn1]! !

!Arc methodsFor: 'displaying'!
displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm

	| newArc tempCenter |
	newArc _ Arc new.
	tempCenter _ aTransformation applyTo: self center.
	newArc center: tempCenter x asInteger @ tempCenter y asInteger.
	newArc quadrant: self quadrant.
	newArc radius: (self radius * aTransformation scale x) asInteger.
	newArc form: self form.
	newArc
		displayOn: aDisplayMedium
		at: 0 @ 0
		clippingBox: clipRect
		rule: anInteger
		fillColor: aForm! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Arc class
	instanceVariableNames: ''!

!Arc class methodsFor: 'examples'!
example
	"Click the button somewhere on the screen. The designated point will
	be the center of an Arc with radius 50 in the 4th quadrant."

	| anArc aForm |
	aForm _ Form extent: 1 @ 30.	"make a long thin Form for display"
	aForm fillBlack.						"turn it black"
	anArc _ Arc new.
	anArc form: aForm.					"set the form for display"
	anArc radius: 50.0.
	anArc center: Sensor waitButton.
	anArc quadrant: 4.
	anArc displayOn: Display.
	Sensor waitButton

	"Arc example"! !
Object subclass: #Archive
	instanceVariableNames: 'members'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Archives'!
!Archive commentStamp: '<historical>' prior: 0!
This is the abstract superclass for file archives. Archives can be read from or written to files, and contain members that represent files and directories.!


!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 19:09'!
addDirectory: aFileName
	^self addDirectory: aFileName as: aFileName
! !

!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:57'!
addDirectory: aFileName as: anotherFileName
	| newMember |
	newMember _ self memberClass newFromDirectory: aFileName.
	self addMember: newMember.
	newMember localFileName: anotherFileName.
	^newMember! !

!Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 18:29'!
addFile: aFileName
	^self addFile: aFileName as: aFileName! !

!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 15:03'!
addFile: aFileName as: anotherFileName
	| newMember |
	newMember _ self memberClass newFromFile: aFileName.
	self addMember: newMember.
	newMember localFileName: anotherFileName.
	^newMember! !

!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 19:09'!
addMember: aMember
	^members addLast: aMember! !

!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 15:03'!
addString: aString as: aFileName
	| newMember |
	newMember _ self memberClass newFromString: aString named: aFileName.
	self addMember: newMember.
	newMember localFileName: aFileName.
	^newMember! !

!Archive methodsFor: 'archive operations' stamp: 'tak 2/2/2005 13:22'!
addTree: aFileNameOrDirectory match: aBlock 
	| nameSize |
	nameSize := aFileNameOrDirectory isString
				ifTrue: [aFileNameOrDirectory size]
				ifFalse: [aFileNameOrDirectory pathName size].
	^ self
		addTree: aFileNameOrDirectory
		removingFirstCharacters: nameSize + 1
		match: aBlock! !

!Archive methodsFor: 'archive operations' stamp: 'tak 2/2/2005 13:00'!
addTree: aFileNameOrDirectory removingFirstCharacters: n 
	^ self
		addTree: aFileNameOrDirectory
		removingFirstCharacters: n
		match: [:e | true]! !

!Archive methodsFor: 'archive operations' stamp: 'tak 2/15/2005 11:27'!
addTree: aFileNameOrDirectory removingFirstCharacters: n match: aBlock
	| dir newMember fullPath relativePath |
	dir _ (aFileNameOrDirectory isString)
		ifTrue: [ FileDirectory on: aFileNameOrDirectory ]
		ifFalse: [ aFileNameOrDirectory ].
	fullPath _ dir pathName, dir slash.
	relativePath _ fullPath copyFrom: n + 1 to: fullPath size.
	(dir entries select: [ :entry | aBlock value: entry])
		do: [ :ea | | fullName |
		fullName _ fullPath, ea name.
		newMember _ ea isDirectory
				ifTrue: [ self memberClass newFromDirectory: fullName ]
				ifFalse: [ self memberClass newFromFile: fullName ].
		newMember localFileName: relativePath, ea name.
		self addMember: newMember.
		ea isDirectory ifTrue: [ self addTree: fullName removingFirstCharacters: n match: aBlock].
	].
! !

!Archive methodsFor: 'archive operations' stamp: 'nk 2/24/2001 14:12'!
canWriteToFileNamed: aFileName
	"Catch attempts to overwrite existing zip file"
	^(members anySatisfy: [ :ea | ea usesFileNamed: aFileName ]) not.
! !

!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'!
contentsOf: aMemberOrName
	| member |
	member _ self member: aMemberOrName.
	member ifNil: [ ^nil ].
	^member contents! !

!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:48'!
extractMember: aMemberOrName
	| member |
	member _ self member: aMemberOrName.
	member ifNil: [ ^nil ].
	member extractToFileNamed: member localFileName inDirectory: FileDirectory default.! !

!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'!
extractMember: aMemberOrName toFileNamed: aFileName
	| member |
	member _ self member: aMemberOrName.
	member ifNil: [ ^nil ].
	member extractToFileNamed: aFileName! !

!Archive methodsFor: 'archive operations' stamp: 'nk 11/11/2002 14:09'!
extractMemberWithoutPath: aMemberOrName
	self extractMemberWithoutPath: aMemberOrName inDirectory: FileDirectory default.! !

!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:48'!
extractMemberWithoutPath: aMemberOrName inDirectory: dir
	| member |
	member _ self member: aMemberOrName.
	member ifNil: [ ^nil ].
	member extractToFileNamed: (FileDirectory localNameFor: member localFileName) inDirectory: dir! !

!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:50'!
memberNamed: aString
	"Return the first member whose zip name or local file name matches aString, or nil"
	^members detect: [ :ea | ea fileName = aString or: [ ea localFileName = aString ]] ifNone: [ ]! !

!Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 18:00'!
memberNames
	^members collect: [ :ea | ea fileName ]! !

!Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 17:58'!
members
	^members! !

!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:50'!
membersMatching: aString
	^members select: [ :ea | (aString match: ea fileName) or: [ aString match: ea localFileName ] ]! !

!Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 17:59'!
numberOfMembers
	^members size! !

!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'!
removeMember: aMemberOrName
	| member |
	member _ self member: aMemberOrName.
	member ifNotNil: [ members remove: member ].
	^member! !

!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'!
replaceMember: aMemberOrName with: newMember
	| member |
	member _ self member: aMemberOrName.
	member ifNotNil: [ members replaceAll: member with: newMember ].
	^member! !

!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 17:24'!
setContentsOf: aMemberOrName to: aString
	| newMember oldMember |
	oldMember _ self member: aMemberOrName.
	newMember _ (self memberClass newFromString: aString named: oldMember fileName)
		copyFrom: oldMember.
	self replaceMember: oldMember with: newMember.! !

!Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 20:58'!
writeTo: aStream
	self subclassResponsibility! !

!Archive methodsFor: 'archive operations' stamp: 'nk 2/24/2001 14:15'!
writeToFileNamed: aFileName
	| stream |
	"Catch attempts to overwrite existing zip file"
	(self canWriteToFileNamed: aFileName)
		ifFalse: [ ^self error: (aFileName, ' is needed by one or more members in this archive') ].
	stream _ StandardFileStream forceNewFileNamed: aFileName.
	self writeTo: stream.
	stream close.! !


!Archive methodsFor: 'initialization' stamp: 'nk 2/21/2001 17:58'!
initialize
	members _ OrderedCollection new.! !


!Archive methodsFor: 'private' stamp: 'nk 2/22/2001 07:56'!
member: aMemberOrName
	^(members includes: aMemberOrName)
		ifTrue: [ aMemberOrName ]
		ifFalse: [ self memberNamed: aMemberOrName ].! !

!Archive methodsFor: 'private' stamp: 'nk 2/21/2001 18:14'!
memberClass
	self subclassResponsibility! !
Object subclass: #ArchiveMember
	instanceVariableNames: 'fileName isCorrupt'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Archives'!
!ArchiveMember commentStamp: '<historical>' prior: 0!
This is the abstract superclass for archive members, which are files or directories stored in archives.!


!ArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 16:00'!
fileName
	^fileName! !

!ArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 16:00'!
fileName: aName
	fileName _ aName! !

!ArchiveMember methodsFor: 'accessing' stamp: 'nk 3/7/2004 16:16'!
isCorrupt
	^isCorrupt ifNil: [ isCorrupt _ false ]! !

!ArchiveMember methodsFor: 'accessing' stamp: 'nk 3/7/2004 16:06'!
isCorrupt: aBoolean
	"Mark this member as being corrupt."
	isCorrupt := aBoolean! !

!ArchiveMember methodsFor: 'accessing' stamp: 'nk 12/20/2002 15:02'!
localFileName: aString
	"Set my internal filename.
	Returns the (possibly new) filename.
	aString will be translated from local FS format into Unix format."

	^fileName _ aString copyReplaceAll: FileDirectory slash with: '/'.! !


!ArchiveMember methodsFor: 'testing' stamp: 'nk 2/21/2001 19:43'!
usesFileNamed: aFileName
	"Do I require aFileName? That is, do I care if it's clobbered?"
	^false! !


!ArchiveMember methodsFor: 'initialization' stamp: 'ar 3/2/2001 18:46'!
close
! !

!ArchiveMember methodsFor: 'initialization' stamp: 'nk 3/7/2004 16:05'!
initialize
	fileName _ ''.
	isCorrupt _ false.! !


!ArchiveMember methodsFor: 'printing' stamp: 'nk 12/20/2002 15:11'!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(;
		nextPutAll: self fileName;
		nextPut: $)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ArchiveMember class
	instanceVariableNames: ''!

!ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:33'!
newDirectoryNamed: aString
	self subclassResponsibility! !

!ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:32'!
newFromFile: aFileName
	self subclassResponsibility! !

!ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:32'!
newFromString: aString
	self subclassResponsibility! !
SystemWindow subclass: #ArchiveViewer
	instanceVariableNames: 'archive fileName memberIndex viewAllContents'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-ArchiveViewer'!
!ArchiveViewer commentStamp: '<historical>' prior: 0!
This is a viewer window that allows editing and viewing of Zip archives.!


!ArchiveViewer methodsFor: 'accessing' stamp: 'nk 2/24/2001 11:03'!
archive
	^archive! !

!ArchiveViewer methodsFor: 'accessing' stamp: 'nk 4/29/2004 10:36'!
directory
	"For compatibility with file list."
	^self error: 'should use readOnlyStream instead!!'! !

!ArchiveViewer methodsFor: 'accessing' stamp: 'nk 2/24/2001 11:03'!
fileName
	^fileName! !

!ArchiveViewer methodsFor: 'accessing' stamp: 'nk 4/29/2004 10:53'!
fullName
	"For compatibility with FileList services.
	If this is called, it means that a service that requires a real filename has been requested.
	So extract the selected member to a temporary file and return that name."

	| fullName dir |
	self canExtractMember ifFalse: [ ^nil ].
	dir _ FileDirectory default directoryNamed: '.archiveViewerTemp'.
	fullName _ dir fullNameFor: self selectedMember localFileName.
	self selectedMember extractInDirectory: dir.
	^fullName! !

!ArchiveViewer methodsFor: 'accessing' stamp: 'nk 2/24/2001 14:56'!
members
	^archive ifNil: [ #() asOrderedCollection ]
		ifNotNil: [ archive members asOrderedCollection ]! !

!ArchiveViewer methodsFor: 'accessing' stamp: 'nk 4/29/2004 10:39'!
readOnlyStream
	"Answer a read-only stream on the selected member.
	For the various stream-reading services."

	^self selectedMember ifNotNilDo: [ :mem | mem contentStream ascii ]! !

!ArchiveViewer methodsFor: 'accessing' stamp: 'nk 2/24/2001 11:17'!
selectedMember
	^memberIndex
		ifNil: [ nil ]
		ifNotNil: [ self members at: memberIndex ifAbsent: [ ] ]! !


!ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 2/24/2001 13:54'!
canCreateNewArchive
	^true! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'dgd 2/21/2003 22:36'!
canExtractAll
	^self members notEmpty! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 2/24/2001 11:12'!
canOpenNewArchive
	^true! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 2/24/2001 13:55'!
canSaveArchive
	^archive notNil! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 2/24/2001 13:49'!
commentArchive
	| newName |
	archive ifNil: [ ^self ].
	newName _ FillInTheBlankMorph
			request: 'New comment for archive:'
			initialAnswer: archive zipFileComment
			centerAt: Sensor cursorPoint
			inWorld: self world
			onCancelReturn: archive zipFileComment
			acceptOnCR: true.
	archive zipFileComment: newName.! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 2/24/2001 23:29'!
createNewArchive
	self setLabel: '(new archive)'.
	archive _ ZipArchive new.
	self memberIndex: 0.
	self changed: #memberList.! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'ar 2/6/2004 13:20'!
extractAll
	| directory |

	self canExtractAll ifFalse: [^ self].
	directory _ FileList2 modalFolderSelector ifNil: [^ self].
	archive extractAllTo: directory.! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:51'!
extractAllPossibleInDirectory: directory
	"Answer true if I can extract all the files in the given directory safely.
	Inform the user as to problems."
	| conflicts |
	self canExtractAll ifFalse: [ ^false ].
	conflicts _ Set new.
	self members do: [ :ea | | fullName |
		fullName _ directory fullNameFor: ea localFileName.
		(ea usesFileNamed: fullName) ifTrue: [ conflicts add: fullName ].
	].
	conflicts notEmpty ifTrue: [ | str |
		str _ WriteStream on: (String new: 200).
		str nextPutAll: 'The following file(s) are needed by archive members and cannot be overwritten:';
			cr.
		conflicts do: [ :ea | str nextPutAll: ea ] separatedBy: [ str cr ].
		self inform: str contents.
		^false.
	].
	conflicts _ Set new.
	self members do: [ :ea | | fullName  |
		fullName _ directory relativeNameFor: ea localFileName.
		(directory fileExists: fullName)
			ifTrue: [ conflicts add: fullName ].
	].
	conflicts notEmpty ifTrue: [ | str |
		str _ WriteStream on: (String new: 200).
		str nextPutAll: 'The following file(s) will be overwritten:'; cr.
		conflicts do: [ :ea | str nextPutAll: ea ] separatedBy: [ str cr ].
		str cr; nextPutAll: 'Is this OK?'.
		^PopUpMenu confirm: str contents.
	].
	^true.
! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 11/11/2002 22:14'!
extractDirectoriesIntoDirectory: directory 
	(self members select: [:ea | ea isDirectory]) 
		do: [:ea | ea extractInDirectory: directory]! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 11/11/2002 22:13'!
extractFilesIntoDirectory: directory 
	(self members reject: [:ea | ea isDirectory]) 
		do: [:ea | ea extractInDirectory: directory]! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 2/24/2001 13:27'!
openNewArchive
	| menu result |
	menu _ StandardFileMenu oldFileMenu: (FileDirectory default) withPattern: '*.zip'.
	result := menu startUpWithCaption: 'Select Zip archive to open...'.
	result ifNil: [ ^self ].
	self fileName: (result directory fullNameFor: result name).
! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 4/19/2002 09:08'!
saveArchive
	| result name |
	self canSaveArchive ifFalse: [ ^self ].
	result _ StandardFileMenu newFile.
	result ifNil: [ ^self ].
	name _ result directory fullNameFor: result name.
	(archive canWriteToFileNamed: name)
		ifFalse: [ self inform: name, ' is used by one or more members
in your archive, and cannot be overwritten.
Try writing to another file name'.
			^self ].
	[ archive writeToFileNamed: name ] on: Error do: [ :ex | self inform: ex description. ].
	self setLabel: name asString.
	self changed: #memberList	"in case CRC's and compressed sizes got set"! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 3/27/2002 12:57'!
writePrependingFile
	| result name prependedName |
	self canSaveArchive ifFalse: [ ^self ].
	result _ (StandardFileMenu newFileMenu: FileDirectory default)
		startUpWithCaption: 'Destination Zip File Name:'.
	result ifNil: [ ^self ].
	name _ result directory fullNameFor: result name.
	(archive canWriteToFileNamed: name)
		ifFalse: [ self inform: name, ' is used by one or more members
in your archive, and cannot be overwritten.
Try writing to another file name'.
			^self ].
	result _ (StandardFileMenu oldFileMenu: FileDirectory default)
		startUpWithCaption: 'Prepended File:'.
	result ifNil: [ ^self ].
	prependedName _ result directory fullNameFor: result name.
	[ archive writeToFileNamed: name prependingFileNamed: prependedName ]
		on: Error
		do: [ :ex | self inform: ex description. ].
	self changed: #memberList	"in case CRC's and compressed sizes got set"! !


!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 6/10/2004 08:16'!
archive: aZipArchive
	archive _ aZipArchive.
	self model: aZipArchive.
	self setLabel: 'New Zip Archive'.
	self memberIndex: 0.
	self changed: #memberList! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 3/7/2004 16:43'!
briefContents
	"Trim to 5000 characters. If the member is longer, then point out that it is trimmed.
	Also warn if the member has a corrupt CRC-32."

	| stream subContents errorMessage |
	self selectedMember ifNil: [^ ''].
	errorMessage _ ''.
	stream _ WriteStream on: (String new: (self selectedMember uncompressedSize min: 5500)).

	[ self selectedMember uncompressedSize > 5000
		ifTrue: [ |  lastLineEndingIndex tempIndex |
			subContents _ self selectedMember contentsFrom: 1 to: 5000.
			lastLineEndingIndex _ subContents lastIndexOf: Character cr.
			tempIndex _ subContents lastIndexOf: Character lf.
			tempIndex > lastLineEndingIndex ifTrue: [lastLineEndingIndex _ tempIndex].
			lastLineEndingIndex = 0
				ifFalse: [subContents _ subContents copyFrom: 1 to: lastLineEndingIndex]]
		ifFalse: [ subContents _ self selectedMember contents ]]
			on: CRCError do: [ :ex |
				errorMessage _ String streamContents: [ :s |
					s nextPutAll: '[ ';
						nextPutAll: (ex messageText copyUpToLast: $( );
						nextPutAll: ' ]' ].
				ex proceed ].

		(errorMessage isEmpty not or: [ self selectedMember isCorrupt ]) ifTrue: [
			stream nextPutAll: '********** WARNING!! Member is corrupt!! ';
					nextPutAll: errorMessage;
					nextPutAll: ' **********'; cr ].

	self selectedMember uncompressedSize > 5000
		ifTrue: [
			stream nextPutAll: 'File ';
				print: self selectedMember fileName;
				nextPutAll: ' is ';
				print: self selectedMember uncompressedSize;
				nextPutAll: ' bytes long.'; cr;
				nextPutAll: 'Click the ''View All Contents'' button above to see the entire file.'; cr; cr;
				nextPutAll: 'Here are the first ';
				print: subContents size;
				nextPutAll: ' characters...'; cr;
				next: 40 put: $-; cr;
				nextPutAll: subContents;
				next: 40 put: $-; cr;
				nextPutAll: '... end of the first ';
				print: subContents size;
				nextPutAll: ' characters.' ]
		ifFalse: [ stream nextPutAll: self selectedMember contents ].
		
		^stream contents
! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 6/10/2004 08:58'!
buttonColor
	^self defaultBackgroundColor darker! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 6/10/2004 08:59'!
buttonOffColor
	^self defaultBackgroundColor darker! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 6/10/2004 08:59'!
buttonOnColor
	^self defaultBackgroundColor! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 3/7/2004 16:45'!
contents
	| contents errorMessage |
	self selectedMember ifNil: [^ ''].
	viewAllContents ifFalse: [^ self briefContents].

 	[ contents _ self selectedMember contents ]
		on: CRCError
		do: [ :ex | errorMessage _ String streamContents: [ :stream |
			stream nextPutAll: '********** WARNING!! Member is corrupt!! [ ';
			nextPutAll: (ex messageText copyUpToLast: $( );
			nextPutAll: '] **********'; cr ].
			ex proceed ].

	^self selectedMember isCorrupt
		ifFalse: [ contents ]
		ifTrue: [ errorMessage, contents ]! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 2/25/2001 00:04'!
contents: aText
	self shouldNotImplement.! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'kfr 9/22/2004 21:19'!
createButtonBar
	| bar button narrowFont registeredFonts |
	registeredFonts _ OrderedCollection new.
	TextStyle knownTextStylesWithoutDefault do:
		[:st | (TextStyle named: st) fonts do: [:f | registeredFonts addLast: f]].		
	narrowFont := registeredFonts detectMin:
			[:ea | ea widthOfString: 'Contents' from: 1 to: 8].
	bar := AlignmentMorph newRow.
	bar
		color: self defaultBackgroundColor;
		rubberBandCells: false;
		vResizing: #shrinkWrap;
		cellInset: 6 @ 0.
	#(#('New\Archive' #canCreateNewArchive #createNewArchive 'Create a new, empty archive and discard this one') #('Load\Archive' #canOpenNewArchive #openNewArchive 'Open another archive and discard this one') #('Save\Archive As' #canSaveArchive #saveArchive 'Save this archive under a new name') #('Extract\All' #canExtractAll #extractAll 'Extract all this archive''s members into a directory') #('Add\File' #canAddMember #addMember 'Add a file to this archive') #('Add from\Clipboard' #canAddMember #addMemberFromClipboard 'Add the contents of the clipboard as a new file') #('Add\Directory' #canAddMember #addDirectory 'Add the entire contents of a directory, with all of its subdirectories') #('Extract\Member As' #canExtractMember #extractMember 'Extract the selected member to a file') #('Delete\Member' #canDeleteMember #deleteMember 'Remove the selected member from this archive') #('Rename\Member' #canRenameMember #renameMember 'Rename the selected member') #('View All\Contents' #canViewAllContents #changeViewAllContents 'Toggle the view of all the selected member''s contents')) 
		do: 
			[:arr | 
			| buttonLabel |
			buttonLabel := (TextMorph new)
						string: arr first withCRs
							fontName: narrowFont familyName
							size: narrowFont pointSize
							wrap: false;
						hResizing: #shrinkWrap;
						lock;
						yourself.
			(button := PluggableButtonMorph 
						on: self
						getState: arr second
						action: arr third)
				vResizing: #shrinkWrap;
				hResizing: #spaceFill;
				onColor: self buttonOnColor offColor: self buttonOffColor;
				label: buttonLabel;
				setBalloonText: arr fourth.
			bar addMorphBack: button.
			buttonLabel composeToBounds].
	^bar! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 6/10/2004 08:59'!
createListHeadingUsingFont: font
	| sm |
	sm _ StringMorph contents: '  uncomp     comp   CRC-32       date     time  file name'.
	font ifNotNil: [ sm font: font ].
	^(AlignmentMorph newColumn)
		color: self defaultBackgroundColor;
		addMorph: sm;
		yourself.! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 6/10/2004 08:59'!
createWindow
	| list heading font text buttonBar |

	font _ (TextStyle named: #DefaultFixedTextStyle)
		ifNotNilDo: [ :ts | ts fontArray first].

	buttonBar _ self createButtonBar.
	self addMorph: buttonBar
		fullFrame: (LayoutFrame fractions: (0@0 corner: 1.0@0.0) offsets: (0@0 corner: 0@44)).

	self minimumExtent: (buttonBar fullBounds width + 20) @ 230.
	self extent: self minimumExtent.

	heading _ self createListHeadingUsingFont: font.
	self addMorph: heading
		fullFrame: (LayoutFrame fractions: (0@0 corner: 1.0@0.0) offsets: (0@44 corner: 0@60)).

	(list _ PluggableListMorph new)
		on: self list: #memberList
		selected: #memberIndex changeSelected: #memberIndex:
		menu: #memberMenu:shifted: keystroke: nil.
	list color: self defaultBackgroundColor.

	font ifNotNil: [list font: font].
	self addMorph: list
		fullFrame: (LayoutFrame fractions: (0@0 corner: 1.0@0.8) offsets: (0@60 corner: 0@0)).

	text _ PluggableTextMorph on: self 
			text: #contents accept: nil
			readSelection: nil menu: nil.
	self addMorph: text
		frame: (0@0.8 corner: 1.0@1.0).
	text lock.

	self setLabel: 'Ned''s Zip Viewer'! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 2/24/2001 23:28'!
fileName: aString
	archive _ ZipArchive new readFrom: aString.
	self setLabel: aString.
	self memberIndex:  0.
	self changed: #memberList! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 6/10/2004 08:16'!
initialize
	super initialize.
	memberIndex _ 0.
	viewAllContents _ false.
! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 6/10/2004 08:29'!
stream: aStream
	archive _ ZipArchive new readFrom: aStream.
	self setLabel: aStream fullName.
	self memberIndex:  0.
	self changed: #memberList! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 6/10/2004 08:15'!
windowIsClosing
	archive ifNotNil: [ archive close ].! !


!ArchiveViewer methodsFor: 'member list' stamp: 'nk 2/24/2001 22:32'!
displayLineFor: aMember
	| stream dateTime |
	stream _ WriteStream on: (String new: 60).
	dateTime _ Time dateAndTimeFromSeconds: aMember lastModTime. 
	stream
		nextPutAll: (aMember uncompressedSize printString padded: #left to: 8 with: $  );
		space;
		nextPutAll: (aMember compressedSize printString padded: #left to: 8 with: $  );
		space; space;
		nextPutAll: (aMember crc32String );
		space; space.
	dateTime first printOn: stream format: #(3 2 1 $- 2 1 2).
	stream space.
	dateTime second print24: true showSeconds: false on: stream.
	stream space; space;
		nextPutAll: (aMember fileName ).
	^stream contents! !

!ArchiveViewer methodsFor: 'member list' stamp: 'nk 2/23/2001 22:48'!
highlightMemberList: list with: morphList
	(morphList at: self memberIndex) color: Color red! !

!ArchiveViewer methodsFor: 'member list' stamp: 'nk 2/24/2001 09:40'!
memberIndex
	^memberIndex! !

!ArchiveViewer methodsFor: 'member list' stamp: 'nk 2/24/2001 23:46'!
memberIndex: n
	memberIndex _ n.
	viewAllContents _ false.
	self changed: #memberIndex.
	self changed: #contents.! !

!ArchiveViewer methodsFor: 'member list' stamp: 'nk 2/24/2001 11:51'!
memberList
	^ self members collect: [ :ea | self displayLineFor: ea ]! !

!ArchiveViewer methodsFor: 'member list' stamp: 'nk 4/29/2004 10:20'!
memberMenu: menu shifted: shifted
	| services |

	menu
		add: 'Comment archive' target: self selector: #commentArchive;
		balloonTextForLastItem: 'Add a comment for the entire archive'.

	self selectedMember ifNotNilDo: [ :member |
		menu
			addLine;
			add: 'Inspect member' target: self selector: #inspectMember;
			balloonTextForLastItem: 'Inspect the selected member';
			add: 'Comment member' target: self selector: #commentMember;
			balloonTextForLastItem: 'Add a comment for the selected member';
			addLine.
		services _ FileList itemsForFile: member fileName.
		menu addServices2: services for: self extraLines: #().
	].


	^menu! !


!ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 23:28'!
addDirectory
	| directory |
	self canAddMember ifFalse: [ ^self ].
	directory _ FileList2 modalFolderSelector.
	directory
		ifNil: [^ self].
	archive addTree: directory removingFirstCharacters: directory pathName size + 1.
	self memberIndex: 0.
	self changed: #memberList.! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 23:26'!
addMember
	| result relative |
	self canAddMember ifFalse: [ ^self ].
	result _ StandardFileMenu oldFile.
	result ifNil: [ ^self ].
	relative _ result directory fullNameFor: result name.
	(relative beginsWith: FileDirectory default pathName)
		ifTrue: [ relative _ relative copyFrom: FileDirectory default pathName size + 2 to: relative size ].
	(archive addFile: relative)
		desiredCompressionMethod: ZipArchive compressionDeflated.
	self memberIndex: self members size.
	self changed: #memberList.! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 23:29'!
addMemberFromClipboard
	| string newName |
	self canAddMember ifFalse: [ ^self ].
	string _ Clipboard clipboardText asString.
	newName _ FillInTheBlankMorph
		request: 'New name for member:'
		initialAnswer: 'clipboardText'.
	newName notEmpty ifTrue: [
		(archive addString: string as: newName) desiredCompressionMethod: ZipArchive compressionDeflated.
		self memberIndex: self members size.
		self changed: #memberList.
	]
! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 14:50'!
canAddMember
	^archive notNil! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 11:02'!
canDeleteMember
	^memberIndex > 0! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 11:02'!
canExtractMember
	^memberIndex > 0! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 11:02'!
canRenameMember
	^memberIndex > 0! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 23:50'!
canViewAllContents
	^memberIndex > 0 and: [ viewAllContents not ]! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'nk 3/7/2004 16:47'!
changeViewAllContents

	(viewAllContents not and: [ self selectedMember notNil and: [ self selectedMember uncompressedSize > 50000 ]])
		ifTrue: [ (PopUpMenu confirm: 'This member''s size is ',
			(self selectedMember uncompressedSize asString),
			'; do you really want to see all that data?')
				ifFalse: [ ^self ]
		].

	viewAllContents _ viewAllContents not.
	self changed: #contents! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 13:50'!
commentMember
	| newName |
	newName _ FillInTheBlankMorph
			request: 'New comment for member:'
			initialAnswer: self selectedMember fileComment
			centerAt: Sensor cursorPoint
			inWorld: self world
			onCancelReturn: self selectedMember fileComment
			acceptOnCR: true.
	self selectedMember fileComment: newName.! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 23:29'!
deleteMember
	self canDeleteMember ifFalse: [ ^self ].
	archive removeMember: self selectedMember.
	self memberIndex:  0.
	self changed: #memberList.
! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'nk 4/29/2004 10:46'!
extractMember
	"Extract the member after prompting for a filename.
	Answer the filename, or nil if error."

	| result name |
	self canExtractMember ifFalse: [ ^nil ].
	result _ StandardFileMenu newFile.
	result ifNil: [ ^nil ].
	name _ (result directory fullNameFor: result name).
	(archive canWriteToFileNamed: name)
		ifFalse: [ self inform: name, ' is used by one or more members
in your archive, and cannot be overwritten.
Try extracting to another file name'.
			^nil ].
	self selectedMember extractToFileNamed: name.
	^name! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 13:01'!
inspectMember
	self selectedMember inspect! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 14:53'!
renameMember
	| newName |
	self canRenameMember ifFalse: [ ^self ].
	newName _ FillInTheBlankMorph
		request: 'New name for member:'
		initialAnswer: self selectedMember fileName.
	newName notEmpty ifTrue: [
		self selectedMember fileName: newName.
		self changed: #memberList
	]! !


!ArchiveViewer methodsFor: 'menu' stamp: 'nk 3/27/2002 12:48'!
buildWindowMenu
	| menu |
	menu _ super buildWindowMenu.
	menu addLine.
	menu add: 'inspect archive' target: archive action: #inspect.
	menu add: 'write prepending file...' target: self action: #writePrependingFile.
	^menu.! !


!ArchiveViewer methodsFor: 'message handling' stamp: 'nk 2/24/2001 13:16'!
perform: selector orSendTo: otherTarget
	^ self perform: selector! !



!ArchiveViewer methodsFor: 'parts bin' stamp: 'dls 10/22/2001 07:40'!
initializeToStandAlone
	self initialize createWindow.! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ArchiveViewer class
	instanceVariableNames: ''!

!ArchiveViewer class methodsFor: 'class initialization' stamp: 'nk 4/29/2004 11:05'!
deleteTemporaryDirectory
	"
	ArchiveViewer deleteTemporaryDirectory
	"

	| dir |
	(dir _ self temporaryDirectory) exists ifTrue: [ dir recursiveDelete ].! !

!ArchiveViewer class methodsFor: 'class initialization' stamp: 'nk 4/29/2004 10:56'!
initialize
	"ArchiveViewer initialize"

	FileList registerFileReader: self.
	Smalltalk addToShutDownList: self.! !

!ArchiveViewer class methodsFor: 'class initialization' stamp: 'sw 2/17/2002 02:35'!
serviceOpenInZipViewer
	"Answer a service for opening in a zip viewer"

	^ SimpleServiceEntry
		provider: self
		label: 'open in zip viewer'
		selector: #openOn: 
		description: 'open in zip viewer'
		buttonLabel: 'open zip'! !

!ArchiveViewer class methodsFor: 'class initialization' stamp: 'nk 4/29/2004 11:06'!
shutDown: quitting
	quitting ifTrue: [ self deleteTemporaryDirectory ].! !


!ArchiveViewer class methodsFor: 'file list services' stamp: 'nk 11/26/2002 12:46'!
extractAllFrom: aFileName
	(self new) fileName: aFileName; extractAll! !

!ArchiveViewer class methodsFor: 'file list services' stamp: 'nk 11/26/2002 12:48'!
serviceAddToNewZip
	"Answer a service for adding the file to a new zip"

	^ FileModifyingSimpleServiceEntry 
		provider: self
		label: 'add file to new zip'
		selector: #addFileToNewZip:
		description: 'add file to new zip'
		buttonLabel: 'to new zip'! !

!ArchiveViewer class methodsFor: 'file list services' stamp: 'nk 11/26/2002 12:15'!
serviceExtractAll
	"Answer a service for opening in a zip viewer"

	^ FileModifyingSimpleServiceEntry 
		provider: self
		label: 'extract all to...'
		selector: #extractAllFrom: 
		description: 'extract all files to a user-specified directory'
		buttonLabel: 'extract all'! !


!ArchiveViewer class methodsFor: 'fileIn/Out' stamp: 'nk 8/21/2004 16:01'!
fileReaderServicesForFile: fullName suffix: suffix 

	|  services |
	services _ OrderedCollection new.
	services add: self serviceAddToNewZip.
	({'zip'.'sar'.'pr'. 'mcz'. '*'} includes: suffix)
		ifTrue: [services add: self serviceOpenInZipViewer.
				services add: self serviceExtractAll].
	^ services! !

!ArchiveViewer class methodsFor: 'fileIn/Out' stamp: 'sd 2/1/2002 21:18'!
services
	
	^ Array 
		with: self serviceAddToNewZip
		with: self serviceOpenInZipViewer
					
			! !

!ArchiveViewer class methodsFor: 'fileIn/Out' stamp: 'nk 4/29/2004 10:56'!
temporaryDirectory
	"Answer a directory to use for unpacking files for the file list services."
	^FileDirectory default directoryNamed: '.archiveViewerTemp'! !


!ArchiveViewer class methodsFor: 'initialize-release' stamp: 'nk 1/30/2002 10:13'!
unload

	FileList unregisterFileReader: self ! !


!ArchiveViewer class methodsFor: 'instance creation' stamp: 'nk 1/30/2002 10:18'!
addFileToNewZip: fullName

	"Add the currently selected file to a new zip"
	| zip |
	zip := (ZipArchive new) 
			addFile: fullName 
			as: (FileDirectory localNameFor: fullName); yourself.
	(self open) archive: zip
! !

!ArchiveViewer class methodsFor: 'instance creation' stamp: 'nk 2/23/2001 21:52'!
open
	^(self new) createWindow; openInWorld.! !

!ArchiveViewer class methodsFor: 'instance creation' stamp: 'nk 11/26/2002 12:45'!
openOn: aFileName
	| newMe |
	newMe _ self new.
	newMe createWindow; fileName: aFileName; openInWorld.
	^newMe! !


!ArchiveViewer class methodsFor: 'parts bin' stamp: 'tak 7/25/2007 00:03'!
descriptionForPartsBin

	^ self partName: 'Zip Tool' translatedNoop
		categories: #()
		documentation: 'A viewer and editor for Zip archive files' translatedNoop
! !
Error subclass: #ArithmeticError
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Kernel'!
ArrayedCollection variableSubclass: #Array
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Arrayed'!
!Array commentStamp: '<historical>' prior: 0!
I present an ArrayedCollection whose elements are objects.!


!Array methodsFor: 'comparing'!
hashMappedBy: map
	"Answer what my hash would be if oops changed according to map."

	self size = 0 ifTrue: [^self hash].
	^(self first hashMappedBy: map) + (self last hashMappedBy: map)! !

!Array methodsFor: 'comparing' stamp: 'ajh 2/2/2002 15:03'!
literalEqual: other

	self class == other class ifFalse: [^ false].
	self size = other size ifFalse: [^ false].
	self with: other do: [:e1 :e2 |
		(e1 literalEqual: e2) ifFalse: [^ false]].
	^ true! !


!Array methodsFor: 'converting' stamp: 'sma 5/12/2000 17:32'!
asArray
	"Answer with the receiver itself."

	^ self! !

!Array methodsFor: 'converting' stamp: 'tpr 11/2/2004 11:31'!
elementsExchangeIdentityWith: otherArray
	"This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray.  At the same time, all pointers to the elements of otherArray are replaced by pointers to the corresponding elements of this array.  The identityHashes remain with the pointers rather than with the objects so that objects in hashed structures should still be properly indexed after the mutation."

	<primitive: 128>
	otherArray class == Array ifFalse: [^ self error: 'arg must be array'].
	self size = otherArray size ifFalse: [^ self error: 'arrays must be same size'].
	(self anySatisfy: [:obj | obj class == SmallInteger]) ifTrue: [^ self error: 'can''t become SmallIntegers'].
	(otherArray anySatisfy: [:obj | obj class == SmallInteger]) ifTrue: [^ self error: 'can''t become SmallIntegers'].
	self with: otherArray do:[:a :b| a == b ifTrue:[^self error:'can''t become yourself']].

	"Must have failed because not enough space in forwarding table (see ObjectMemory-prepareForwardingTableForBecoming:with:twoWay:).  Do GC and try again only once"
	(Smalltalk bytesLeft: true) = Smalltalk primitiveGarbageCollect
		ifTrue: [^ self primitiveFailed].
	^ self elementsExchangeIdentityWith: otherArray! !

!Array methodsFor: 'converting' stamp: 'di 3/28/1999 10:23'!
elementsForwardIdentityTo: otherArray
	"This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray.  The identityHashes remain with the pointers rather than with the objects so that the objects in this array should still be properly indexed in any existing hashed structures after the mutation."
	<primitive: 72>
	self primitiveFailed! !

!Array methodsFor: 'converting' stamp: 'brp 9/26/2003 08:09'!
elementsForwardIdentityTo: otherArray copyHash: copyHash
	"This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray.  The identityHashes remain with the pointers rather than with the objects so that the objects in this array should still be properly indexed in any existing hashed structures after the mutation."
	<primitive: 249>
	self primitiveFailed! !

!Array methodsFor: 'converting' stamp: 'ar 4/10/2005 18:03'!
evalStrings
	   "Allows you to construct literal arrays.
    #(true false nil '5@6' 'Set new' '''text string''') evalStrings
    gives an array with true, false, nil, a Point, a Set, and a String
    instead of just a bunch of Symbols"
    | it |

    ^ self collect: [:each |
        it _ each.
        each == #true ifTrue: [it _ true].
		      each == #false ifTrue: [it _ false].
        each == #nil ifTrue: [it _ nil].
        (each isString and:[each isSymbol not]) ifTrue: [
			it _ Compiler evaluate: each].
        each class == Array ifTrue: [it _ it evalStrings].
        it]! !


!Array methodsFor: 'printing' stamp: 'sma 5/12/2000 14:11'!
isLiteral
	^ self allSatisfy: [:each | each isLiteral]! !

!Array methodsFor: 'printing' stamp: 'sma 6/1/2000 09:39'!
printOn: aStream
	aStream nextPut: $#.
	self printElementsOn: aStream! !

!Array methodsFor: 'printing'!
storeOn: aStream 
	"Use the literal form if possible."

	self isLiteral
		ifTrue: 
			[aStream nextPut: $#; nextPut: $(.
			self do: 
				[:element | 
				element printOn: aStream.
				aStream space].
			aStream nextPut: $)]
		ifFalse: [super storeOn: aStream]! !


!Array methodsFor: 'private' stamp: 'sma 6/3/2000 21:39'!
hasLiteral: literal
	"Answer true if literal is identical to any literal in this array, even 
	if imbedded in further array structure. This method is only intended 
	for private use by CompiledMethod hasLiteralSymbol:"

	| lit |
	1 to: self size do: 
		[:index | 
		(lit _ self at: index) == literal ifTrue: [^ true].
		(lit class == Array and: [lit hasLiteral: literal]) ifTrue: [^ true]].
	^ false! !

!Array methodsFor: 'private' stamp: 'di 8/15/97 09:55'!
hasLiteralSuchThat: litBlock
	"Answer true if litBlock returns true for any literal in this array, even if imbedded in further array structure.  This method is only intended for private use by CompiledMethod hasLiteralSuchThat:"
	| lit |
	1 to: self size do:
		[:index | lit _ self at: index.
		(litBlock value: lit) ifTrue: [^ true].
		(lit class == Array and: [lit hasLiteralSuchThat: litBlock]) ifTrue: [^ true]].
	^false! !

!Array methodsFor: 'private'!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	"Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
	<primitive: 105>
	super replaceFrom: start to: stop with: replacement startingAt: repStart! !


!Array methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 01:42'!
byteEncode:aStream
	aStream writeArray:self.
! !

!Array methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 01:55'!
storeOnStream:aStream
	self isLiteral ifTrue: [super storeOnStream:aStream] ifFalse:[aStream writeCollection:self].
! !


!Array methodsFor: 'file in/out' stamp: 'tk 9/28/2000 15:35'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  If I am one of two shared global arrays, write a proxy instead."

self == (TextConstants at: #DefaultTabsArray) ifTrue: [
	dp _ DiskProxy global: #TextConstants selector: #at: args: #(DefaultTabsArray).
	refStrm replace: self with: dp.
	^ dp].
self == (TextConstants at: #DefaultMarginTabsArray) ifTrue: [
	dp _ DiskProxy global: #TextConstants selector: #at: args: #(DefaultMarginTabsArray).
	refStrm replace: self with: dp.
	^ dp].
^ super objectForDataStream: refStrm! !


!Array methodsFor: 'copying' stamp: 'yo 10/16/2006 12:38'!
copy

	^ self clone.
! !

!Array methodsFor: 'copying' stamp: 'ar 2/11/2001 01:55'!
copyWithDependent: newElement
	self size = 0 ifTrue:[^DependentsArray with: newElement].
	^self copyWith: newElement! !

!Array methodsFor: 'copying' stamp: 'yo 10/16/2006 12:40'!
shallowCopy

	^ self clone.
! !


!Array methodsFor: 'accessing' stamp: 'ar 8/26/2001 22:02'!
atWrap: index 
	"Optimized to go through the primitive if possible"
	<primitive: 60>
	^ self at: index - 1 \\ self size + 1! !

!Array methodsFor: 'accessing' stamp: 'ar 8/26/2001 22:03'!
atWrap: index put: anObject
	"Optimized to go through the primitive if possible"
	<primitive: 61>
	^ self at: index - 1 \\ self size + 1 put: anObject! !


!Array methodsFor: 'arithmetic' stamp: 'raok 10/22/2002 20:09'!
+* aCollection
	"Premultiply aCollection by self.  aCollection should be an Array or Matrix.
	 The name of this method is APL's +.x squished into Smalltalk syntax."

	^aCollection preMultiplyByArray: self
! !

!Array methodsFor: 'arithmetic' stamp: 'raok 10/22/2002 20:10'!
preMultiplyByArray: a
	"Answer a+*self where a is an Array.  Arrays are always understood as column vectors,
	 so an n element Array is an n*1 Array.  This multiplication is legal iff self size = 1."

	self size = 1 ifFalse: [self error: 'dimensions do not conform'].
	^a * self first! !

!Array methodsFor: 'arithmetic' stamp: 'raok 10/22/2002 20:08'!
preMultiplyByMatrix: m
	"Answer m+*self where m is a Matrix."
	|s|

	m columnCount = self size ifFalse: [self error: 'dimensions do not conform'].
	^(1 to: m rowCount) collect: [:row |
		s _ 0.
		1 to: self size do: [:k | s _ (m at: row at: k) * (self at: k) + s].
		s]! !


!Array methodsFor: '*green' stamp: 'sw 5/20/2003 11:45'!
allSymbols
	"Answer an array of all the symbols in the receiver, including those within nested arrays."

	^ (Array streamContents:
		[:aStream |
			self do:
				[:elem | (elem isKindOf: Array)
					ifTrue:
						[aStream nextPutAll: elem allSymbols]
					ifFalse:
						[(elem isKindOf: Symbol) ifTrue:
							[aStream nextPut: elem]]]]) asSet asArray

"#((first second) third (fourth (fifth sixth))) allSymbols"! !


!Array methodsFor: 'translating' stamp: 'bf 9/27/2007 12:20'!
literalStringsDo: aBlock 
	"Assuming the receiver receiver is a literal, evaluate aBlock with all Strings (but not Symbols) within it."
	self do: [:each | each literalStringsDo: aBlock]! !

!Array methodsFor: 'translating' stamp: 'KR 9/27/2007 12:20'!
translatedNoop
	"This is correspondence gettext_noop() in gettext."
	^ self! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Array class
	instanceVariableNames: ''!

!Array class methodsFor: 'plugin generation' stamp: 'acg 9/17/1999 01:12'!
ccgDeclareCForVar: aSymbolOrString

	^'int *', aSymbolOrString! !

!Array class methodsFor: 'plugin generation' stamp: 'acg 9/17/1999 01:12'!
ccg: cg emitLoadFor: aString from: anInteger on: aStream

	cg emitLoad: aString asIntPtrFrom: anInteger on: aStream! !

!Array class methodsFor: 'plugin generation' stamp: 'acg 9/19/1999 13:10'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg 
		ccgLoad: aBlock 
		expr: aString 
		asIntPtrFrom: anInteger
		andThen: (cg ccgValBlock: 'isIndexable')! !


!Array class methodsFor: 'brace support' stamp: 'di 11/18/1999 22:53'!
braceStream: nElements
	"This method is used in compilation of brace constructs.
	It MUST NOT be deleted or altered."

	^ WriteStream basicNew braceArray: (self new: nElements)
! !

!Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:16'!
braceWithNone
	"This method is used in compilation of brace constructs.
	It MUST NOT be deleted or altered."

	^ self new: 0! !

!Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:16'!
braceWith: a
	"This method is used in compilation of brace constructs.
	It MUST NOT be deleted or altered."

	| array |
	array _ self new: 1.
	array at: 1 put: a.
	^ array! !

!Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:15'!
braceWith: a with: b 
	"This method is used in compilation of brace constructs.
	It MUST NOT be deleted or altered."

	| array |
	array _ self new: 2.
	array at: 1 put: a.
	array at: 2 put: b.
	^ array! !

!Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:17'!
braceWith: a with: b with: c 
	"This method is used in compilation of brace constructs.
	It MUST NOT be deleted or altered."

	| array |
	array _ self new: 3.
	array at: 1 put: a.
	array at: 2 put: b.
	array at: 3 put: c.
	^ array! !

!Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:17'!
braceWith: a with: b with: c with: d
	"This method is used in compilation of brace constructs.
	It MUST NOT be deleted or altered."

	| array |
	array _ self new: 4.
	array at: 1 put: a.
	array at: 2 put: b.
	array at: 3 put: c.
	array at: 4 put: d.
	^ array! !


!Array class methodsFor: 'instance creation' stamp: 'md 7/19/2004 12:34'!
new: sizeRequested 
	"Answer an instance of this class with the number of indexable
	variables specified by the argument, sizeRequested.
	
	This is a shortcut (direct call of primitive, no #initialize, for performance"

	<primitive: 71>  "This method runs primitively if successful"
	^ self basicNew: sizeRequested  "Exceptional conditions will be handled in basicNew:"
! !


!Array class methodsFor: '*siss-instance creation' stamp: 'yo 3/5/2007 12:00'!
sissCreateInstanceFromSexp: sexp idref: idref from: from to: to

	^ self sissBasicCreateInstanceFromSexp: sexp idref: idref from: from to: to! !
ArrayedCollection subclass: #Array2D
	instanceVariableNames: 'width contents'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Array2D'!
!Array2D commentStamp: '<historical>' prior: 0!
A simple 2D-Array implementation. 

Neither storing nor sorting (otherwise inherited from ArrayedCollection) will work. Neither comparing nor most accessing mehods inherited from Sequenceable collection will work.  Actually, it's a bad idea to inherit this class from collection at all!!!


!Array2D methodsFor: 'accessing' stamp: 'sma 4/22/2000 18:20'!
atAllPut: anObject
	"Put anObject at every one of the receiver's indices."

	contents atAllPut: anObject! !

!Array2D methodsFor: 'accessing' stamp: 'sma 4/22/2000 18:16'!
at: x at: y
	"Answer the element at index x,y."

	^ contents at: (self indexX: x y: y)! !

!Array2D methodsFor: 'accessing' stamp: 'sma 4/22/2000 18:20'!
at: x at: y add: value
	"Add value (using #+) to the existing element at index x,y."

	| index |
	index _ self indexX: x y: y.
	^ contents at: index put: (contents at: index) + value! !

!Array2D methodsFor: 'accessing' stamp: 'sma 4/22/2000 18:20'!
at: x at: y put: value
	"Store value at index x,y and answer it."

	^ contents at: (self indexX: x y: y) put: value! !

!Array2D methodsFor: 'accessing' stamp: 'sma 4/22/2000 18:22'!
extent
	"Answer the receiver's dimensions as point."

	^ self width @ self height! !

!Array2D methodsFor: 'accessing' stamp: 'sma 4/22/2000 18:21'!
height
    "Answer the receiver's second dimension."

	^ contents size // width! !

!Array2D methodsFor: 'accessing' stamp: 'sma 4/22/2000 18:22'!
size
	^ contents size! !

!Array2D methodsFor: 'accessing' stamp: 'sma 4/22/2000 18:22'!
width
	"Answer the receiver's first dimension."

	^ width! !


!Array2D methodsFor: 'copying' stamp: 'sma 4/22/2000 18:37'!
copy
	^ super copy setContents: contents copy! !


!Array2D methodsFor: 'enumeration' stamp: 'sma 4/22/2000 18:14'!
do: aBlock
	"Iterate with X varying most quickly.  6/20/96 tk"

	contents do: aBlock! !

!Array2D methodsFor: 'enumeration' stamp: 'je 3/23/2003 17:21'!
rowAndColumnValuesDo: aBlock
	1 to: self width do: [:col |
		1 to: self height do: [:row |
			aBlock value: row value: col value: (self at: col at: row)]]! !

!Array2D methodsFor: 'enumeration' stamp: 'sma 4/22/2000 18:39'!
rowsAndColumnsDo: aBlock
	1 to: self width do: [:col |
		1 to: self height do: [:row |
			aBlock value: row value: col]]! !


!Array2D methodsFor: 'converting' stamp: 'sma 4/22/2000 18:38'!
asArray
	^ contents copy! !


!Array2D methodsFor: 'private' stamp: 'sma 4/22/2000 18:24'!
extent: extent fromArray: anArray
	"Load receiver up from a 1-D array.  X varies most quickly.  6/20/96 tk"

	extent x * extent y = anArray size ifFalse:
		[^ self error: 'dimensions don''t match'].
	width _ extent x.
	contents _ anArray! !

!Array2D methodsFor: 'private' stamp: 'sma 4/22/2000 18:16'!
indexX: x y: y
	(x < 1 or: [x > width]) ifTrue: [self errorSubscriptBounds: x].
	^ y - 1 * width + x! !

!Array2D methodsFor: 'private' stamp: 'sma 4/22/2000 18:37'!
setContents: aCollection
	contents _ aCollection! !

!Array2D methodsFor: 'private' stamp: 'sma 4/22/2000 18:13'!
width: x height: y type: collectionClass
	"Set the number of elements in the first and second dimension.
	collectionClass can be Array or String or ByteArray."

	contents == nil ifFalse:
		[self error: 'No runtime size change yet'].
		"later move all the elements to the new sized array"
	width _ x.
	contents _ collectionClass new: x * y! !


!Array2D methodsFor: 'accessing rows/columns' stamp: 'sma 4/22/2000 18:27'!
atCol: x
	"Answer a whole column."

	| column |
	column _ contents class new: self height.
	1 to: self height do: [:index | column at: index put: (self at: x at: index)].
	^ column! !

!Array2D methodsFor: 'accessing rows/columns' stamp: 'sma 4/22/2000 18:30'!
atCol: x put: aCollection
	"Put in a whole column."

	aCollection size = self height ifFalse: [self error: 'wrong column size'].
	aCollection doWithIndex: [:value :y | self at: x at: y put: value].
	^ aCollection! !

!Array2D methodsFor: 'accessing rows/columns' stamp: 'sma 4/22/2000 18:27'!
atRow: y
    "Answer a whole row."

	(y < 1 or: [y > self height]) ifTrue: [self errorSubscriptBounds: y].
	^ contents copyFrom: y - 1 * width + 1 to: y * width! !

!Array2D methodsFor: 'accessing rows/columns' stamp: 'sma 4/22/2000 18:30'!
atRow: y put: aCollection
	"Put in a whole row."

	aCollection size = self width ifFalse: [self error: 'wrong row size'].
	aCollection doWithIndex: [:value :x | self at: x at: y put: value].
	^ aCollection! !


!Array2D methodsFor: '*siss-private' stamp: 'yo 4/3/2007 10:45'!
sissInstVarNamed: varName put: childInst in: context

	self sissBasicInstVarNamed: varName put: childInst in: context
! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Array2D class
	instanceVariableNames: ''!

!Array2D class methodsFor: 'instance creation' stamp: 'sma 4/22/2000 18:40'!
extent: aPoint
	^ self width: aPoint x height: aPoint y! !

!Array2D class methodsFor: 'instance creation'!
new
	"Override ArrayedCollection.  6/20/96 tk"
	^ self basicNew! !

!Array2D class methodsFor: 'instance creation' stamp: 'sma 4/22/2000 18:11'!
new: size
	self error: 'Use >>self width: x height: y<< instead'! !

!Array2D class methodsFor: 'instance creation' stamp: 'sma 4/22/2000 18:10'!
width: width height: height
	^ self basicNew width: width height: height type: Array! !

!Array2D class methodsFor: 'instance creation' stamp: 'sma 4/22/2000 18:10'!
width: width height: height type: collectionClass
	^ self basicNew width: width height: height type: collectionClass! !


!Array2D class methodsFor: '*siss-instance creation' stamp: 'yo 3/5/2007 12:00'!
sissCreateInstanceFromSexp: sexp idref: idref from: from to: to

	^ self sissBasicCreateInstanceFromSexp: sexp idref: idref from: from to: to! !
TestCase subclass: #Array2DTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Array2D'!

!Array2DTest methodsFor: 'testing' stamp: 'md 2/14/2004 18:14'!
testRowAndColumnValuesDo
	| foo |

	 foo _ Array2D width: 5 height: 20.   
	 self shouldnt: [foo rowAndColumnValuesDo: [ :row :col :val ]] raise: Error.
! !
SequenceableCollection subclass: #ArrayedCollection
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Abstract'!
!ArrayedCollection commentStamp: '<historical>' prior: 0!
I am an abstract collection of elements with a fixed range of integers (from 1 to n>=0) as external keys.!


!ArrayedCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:36'!
size
	"Answer how many elements the receiver contains."

	<primitive: 62>
	^ self basicSize! !


!ArrayedCollection methodsFor: 'adding' stamp: 'sma 5/12/2000 14:09'!
add: newObject
	self shouldNotImplement! !


!ArrayedCollection methodsFor: 'filter streaming' stamp: 'sma 5/12/2000 14:20'!
flattenOnStream: aStream 
	aStream writeArrayedCollection: self! !


!ArrayedCollection methodsFor: 'printing'!
storeOn: aStream

	aStream nextPutAll: '(('.
	aStream nextPutAll: self class name.
	aStream nextPutAll: ' new: '.
	aStream store: self size.
	aStream nextPut: $).
	(self storeElementsFrom: 1 to: self size on: aStream)
		ifFalse: [aStream nextPutAll: '; yourself'].
	aStream nextPut: $)! !


!ArrayedCollection methodsFor: 'private'!
defaultElement

	^nil! !

!ArrayedCollection methodsFor: 'private'!
storeElementsFrom: firstIndex to: lastIndex on: aStream

	| noneYet defaultElement arrayElement |
	noneYet _ true.
	defaultElement _ self defaultElement.
	firstIndex to: lastIndex do: 
		[:index | 
		arrayElement _ self at: index.
		arrayElement = defaultElement
			ifFalse: 
				[noneYet
					ifTrue: [noneYet _ false]
					ifFalse: [aStream nextPut: $;].
				aStream nextPutAll: ' at: '.
				aStream store: index.
				aStream nextPutAll: ' put: '.
				aStream store: arrayElement]].
	^noneYet! !


!ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 18:18'!
asSortedArray
	self isSorted ifTrue: [^ self asArray].
	^ super asSortedArray! !

!ArrayedCollection methodsFor: 'sorting' stamp: 'sma 6/1/2000 11:57'!
isSorted
	"Return true if the receiver is sorted by the given criterion.
	Optimization for isSortedBy: [:a :b | a <= b]."

	| lastElm elm |
	self isEmpty ifTrue: [^ true].
	lastElm _ self first.
	2 to: self size do: 
		[:index | 
		elm _ self at: index.
		lastElm <= elm ifFalse: [^ false].
		lastElm _ elm].
	^ true! !

!ArrayedCollection methodsFor: 'sorting' stamp: 'sma 6/1/2000 11:58'!
isSortedBy: aBlock
	"Return true if the receiver is sorted by the given criterion."

	| lastElm elm |
	self isEmpty ifTrue: [^ true].
	lastElm _ self first.
	2 to: self size do: 
		[:index | 
		elm _ self at: index.
		(aBlock value: lastElm value: elm) ifFalse: [^ false].
		lastElm _ elm].
	^ true! !

!ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 14:28'!
mergeFirst: first middle: middle last: last into: dst by: aBlock
	"Private. Merge the sorted ranges [first..middle] and [middle+1..last] 
	of the receiver into the range [first..last] of dst."

	| i1 i2 val1 val2 out |
	i1 _ first.
	i2 _ middle + 1.
	val1 _ self at: i1.
	val2 _ self at: i2.
	out _ first - 1.  "will be pre-incremented"

	"select 'lower' half of the elements based on comparator"
	[(i1 <= middle) and: [i2 <= last]] whileTrue:
		[(aBlock value: val1 value: val2)
			ifTrue: [dst at: (out _ out + 1) put: val1.
					val1 _ self at: (i1 _ i1 + 1)]
			ifFalse: [dst at: (out _ out + 1) put: val2.
					i2 _ i2 + 1.
					i2 <= last ifTrue: [val2 _ self at: i2]]].

	"copy the remaining elements"
	i1 <= middle
		ifTrue: [dst replaceFrom: out + 1 to: last with: self startingAt: i1]
		ifFalse: [dst replaceFrom: out + 1 to: last with: self startingAt: i2]! !

!ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 14:25'!
mergeSortFrom: startIndex to: stopIndex by: aBlock
	"Sort the given range of indices using the mergesort algorithm.
	Mergesort is a worst-case O(N log N) sorting algorithm that usually
	does only half as many comparisons as heapsort or quicksort."

	"Details: recursively split the range to be sorted into two halves,
	mergesort each half, then merge the two halves together. An extra 
	copy of the data is used as temporary storage and successive merge 
	phases copy data back and forth between the receiver and this copy.
	The recursion is set up so that the final merge is performed into the
	receiver, resulting in the receiver being completely sorted."

	self size <= 1 ifTrue: [^ self].  "nothing to do"
	startIndex = stopIndex ifTrue: [^ self].
	self assert: [startIndex >= 1 and: [startIndex < stopIndex]]. "bad start index"
	self assert: [stopIndex <= self size]. "bad stop index"
	self
		mergeSortFrom: startIndex
		to: stopIndex 
		src: self clone 
		dst: self 
		by: aBlock! !

!ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 14:26'!
mergeSortFrom: first to: last src: src dst: dst by: aBlock
	"Private. Split the range to be sorted in half, sort each half, and 
	merge the two half-ranges into dst."

	| middle |
	first = last ifTrue: [^ self].
	middle _ (first + last) // 2.
	self mergeSortFrom: first to: middle src: dst dst: src by: aBlock.
	self mergeSortFrom: middle + 1 to: last src: dst dst: src by: aBlock.
	src mergeFirst: first middle: middle last: last into: dst by: aBlock! !

!ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 14:22'!
sort
	"Sort this array into ascending order using the '<=' operator."

	self sort: [:a :b | a <= b]! !

!ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 14:21'!
sort: aSortBlock 
	"Sort this array using aSortBlock. The block should take two arguments
	and return true if the first element should preceed the second one."

	self
		mergeSortFrom: 1
		to: self size
		by: aSortBlock! !


!ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 15:22'!
byteSize
	^self basicSize * self bytesPerBasicElement
! !

!ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 16:28'!
bytesPerBasicElement
	"Answer the number of bytes that each of my basic elements requires.
	In other words:
		self basicSize * self bytesPerBasicElement
	should equal the space required on disk by my variable sized representation."
	^self class isBytes ifTrue: [ 1 ] ifFalse: [ 4 ]! !

!ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 18:51'!
bytesPerElement
	^self class isBytes ifTrue: [ 1 ] ifFalse: [ 4 ].
! !

!ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 7/30/2004 17:50'!
restoreEndianness
	"This word object was just read in from a stream.  It was stored in Big Endian (Mac) format.  Reverse the byte order if the current machine is Little Endian.
	We only intend this for non-pointer arrays.  Do nothing if I contain pointers."

	self class isPointers | self class isWords not ifTrue: [^self].
	SmalltalkImage current  isLittleEndian 
		ifTrue: 
			[Bitmap 
				swapBytesIn: self
				from: 1
				to: self basicSize]! !

!ArrayedCollection methodsFor: 'objects from disk' stamp: 'md 12/12/2003 17:01'!
swapBytesFrom: start to: stop
	"Perform a bigEndian/littleEndian byte reversal of my words.
	We only intend this for non-pointer arrays.  Do nothing if I contain pointers."
	| hack blt |
	self deprecated: 'Use BitMap class>>swapBytesIn:from:to:'.
	self class isPointers | self class isWords not ifTrue: [^ self].

	"The implementation is a hack, but fast for large ranges"
	hack _ Form new hackBits: self.
	blt _ (BitBlt toForm: hack) sourceForm: hack.
	blt combinationRule: Form reverse.  "XOR"
	blt sourceY: start-1; destY: start-1; height: stop-start+1; width: 1.
	blt sourceX: 0; destX: 3; copyBits.  "Exchange bytes 0 and 3"
	blt sourceX: 3; destX: 0; copyBits.
	blt sourceX: 0; destX: 3; copyBits.
	blt sourceX: 1; destX: 2; copyBits.  "Exchange bytes 1 and 2"
	blt sourceX: 2; destX: 1; copyBits.
	blt sourceX: 1; destX: 2; copyBits.
! !

!ArrayedCollection methodsFor: 'objects from disk' stamp: 'tk 3/7/2001 17:36'!
swapHalves
		"A normal switch in endianness (byte order in words) reverses the order of 4 bytes.  That is not correct for SoundBuffers, which use 2-bytes units.  If a normal switch has be done, this method corrects it further by swapping the two halves of the long word.
	This method is only used for 16-bit quanities in SoundBuffer, ShortIntegerArray, etc."

	| hack blt |
	"The implementation is a hack, but fast for large ranges"
	hack _ Form new hackBits: self.
	blt _ (BitBlt toForm: hack) sourceForm: hack.
	blt combinationRule: Form reverse.  "XOR"
	blt sourceY: 0; destY: 0; height: self size; width: 2.
	blt sourceX: 0; destX: 2; copyBits.  "Exchange bytes 0&1 with 2&3"
	blt sourceX: 2; destX: 0; copyBits.
	blt sourceX: 0; destX: 2; copyBits.! !

!ArrayedCollection methodsFor: 'objects from disk' stamp: 'tk 3/7/2001 18:07'!
writeOnGZIPByteStream: aStream 
	"We only intend this for non-pointer arrays.  Do nothing if I contain pointers."

	self class isPointers | self class isWords not ifTrue: [^ super writeOnGZIPByteStream: aStream].
		"super may cause an error, but will not be called."
	
	aStream nextPutAllWordArray: self! !

!ArrayedCollection methodsFor: 'objects from disk' stamp: 'ar 5/17/2001 19:50'!
writeOn: aStream 
	"Store the array of bits onto the argument, aStream.  (leading byte ~= 16r80) identifies this as raw bits (uncompressed).  Always store in Big Endian (Mac) byte order.  Do the writing at BitBlt speeds. We only intend this for non-pointer arrays.  Do nothing if I contain pointers."
	self class isPointers | self class isWords not ifTrue: [^ super writeOn: aStream].
				"super may cause an error, but will not be called."
	aStream nextInt32Put: self basicSize.
	aStream nextWordsPutAll: self.! !


!ArrayedCollection methodsFor: '*siss-private' stamp: 'yo 3/4/2007 03:53'!
sissInstVarNamed: varName put: childInst

	self sissWithBasicAt ifTrue: [
		self basicAt: varName asInteger put: childInst
	] ifFalse: [
		self at: varName asInteger put: childInst
	].
! !

!ArrayedCollection methodsFor: '*siss-private' stamp: 'yo 4/3/2007 10:45'!
sissInstVarNamed: varName put: childInst in: context

	self sissWithBasicAt ifTrue: [
		self basicAt: varName asInteger put: childInst
	] ifFalse: [
		self at: varName asInteger put: childInst
	].
! !

!ArrayedCollection methodsFor: '*siss-private' stamp: 'yo 3/3/2007 21:39'!
sissWithBasicAt

	^ true.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ArrayedCollection class
	instanceVariableNames: ''!

!ArrayedCollection class methodsFor: 'instance creation'!
new
	"Answer a new instance of me, with size = 0."

	^self new: 0! !

!ArrayedCollection class methodsFor: 'instance creation' stamp: 'ar 5/17/2001 19:50'!
newFromStream: s
	"Only meant for my subclasses that are raw bits and word-like.  For quick unpack form the disk."
	| len |

	self isPointers | self isWords not ifTrue: [^ super newFromStream: s].
		"super may cause an error, but will not be called."

	s next = 16r80 ifTrue:
		["A compressed format.  Could copy what BitMap does, or use a 
		special sound compression format.  Callers normally compress their own way."
		^ self error: 'not implemented'].
	s skip: -1.
	len _ s nextInt32.
	^ s nextWordsInto: (self basicNew: len)! !

!ArrayedCollection class methodsFor: 'instance creation'!
newFrom: aCollection 
	"Answer an instance of me containing the same elements as aCollection."
	| newArray |
	newArray _ self new: aCollection size.
	1 to: aCollection size do: [:i | newArray at: i put: (aCollection at: i)].
	^ newArray

"	Array newFrom: {1. 2. 3}
	{1. 2. 3} as: Array
	{1. 2. 3} as: ByteArray
	{$c. $h. $r} as: String
	{$c. $h. $r} as: Text
"! !

!ArrayedCollection class methodsFor: 'instance creation'!
new: size withAll: value 
	"Answer an instance of me, with number of elements equal to size, each 
	of which refers to the argument, value."

	^(self new: size) atAllPut: value! !

!ArrayedCollection class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 17:37'!
withAll: aCollection
	"Create a new collection containing all the elements from aCollection."

	^ (self new: aCollection size) replaceFrom: 1 to: aCollection size with: aCollection! !

!ArrayedCollection class methodsFor: 'instance creation'!
with: anObject 
	"Answer a new instance of me, containing only anObject."

	| newCollection |
	newCollection _ self new: 1.
	newCollection at: 1 put: anObject.
	^newCollection! !

!ArrayedCollection class methodsFor: 'instance creation'!
with: firstObject with: secondObject 
	"Answer a new instance of me, containing firstObject and secondObject."

	| newCollection |
	newCollection _ self new: 2.
	newCollection at: 1 put: firstObject.
	newCollection at: 2 put: secondObject.
	^newCollection! !

!ArrayedCollection class methodsFor: 'instance creation'!
with: firstObject with: secondObject with: thirdObject 
	"Answer a new instance of me, containing only the three arguments as
	elements."

	| newCollection |
	newCollection _ self new: 3.
	newCollection at: 1 put: firstObject.
	newCollection at: 2 put: secondObject.
	newCollection at: 3 put: thirdObject.
	^newCollection! !

!ArrayedCollection class methodsFor: 'instance creation'!
with: firstObject with: secondObject with: thirdObject with: fourthObject 
	"Answer a new instance of me, containing only the three arguments as
	elements."

	| newCollection |
	newCollection _ self new: 4.
	newCollection at: 1 put: firstObject.
	newCollection at: 2 put: secondObject.
	newCollection at: 3 put: thirdObject.
	newCollection at: 4 put: fourthObject.
	^newCollection! !

!ArrayedCollection class methodsFor: 'instance creation'!
with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject
	"Answer a new instance of me, containing only the five arguments as
	elements."

	| newCollection |
	newCollection _ self new: 5.
	newCollection at: 1 put: firstObject.
	newCollection at: 2 put: secondObject.
	newCollection at: 3 put: thirdObject.
	newCollection at: 4 put: fourthObject.
	newCollection at: 5 put: fifthObject.
	^newCollection! !

!ArrayedCollection class methodsFor: 'instance creation' stamp: 'sw 10/24/1998 22:22'!
with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject with: sixthObject
	"Answer a new instance of me, containing only the 6 arguments as elements."

	| newCollection |
	newCollection _ self new: 6.
	newCollection at: 1 put: firstObject.
	newCollection at: 2 put: secondObject.
	newCollection at: 3 put: thirdObject.
	newCollection at: 4 put: fourthObject.
	newCollection at: 5 put: fifthObject.
	newCollection at: 6 put: sixthObject.
	^ newCollection! !


!ArrayedCollection class methodsFor: 'plugin generation' stamp: 'acg 9/20/1999 10:03'!
ccg: cg generateCoerceToOopFrom: aNode on: aStream

	self instSize > 0 ifTrue: 
		[self error: 'cannot auto-coerce arrays with named instance variables'].
	cg generateCoerceToObjectFromPtr: aNode on: aStream! !

!ArrayedCollection class methodsFor: 'plugin generation' stamp: 'acg 10/5/1999 06:18'!
ccg: cg generateCoerceToValueFrom: aNode on: aStream

	cg 
		generateCoerceToPtr: (self ccgDeclareCForVar: '')
		fromObject: aNode on: aStream! !


!ArrayedCollection class methodsFor: '*siss-instance creation' stamp: 'yo 3/5/2007 11:58'!
sissCreateInstanceFromSexp: sexp idref: idref from: from to: to
	| inst |
	inst _ self newFromStream: (Base64MimeConverter mimeDecodeToBytes: (sexp attributeAt: #value) readStream) reset.
	idref ifNotNil: [to at: idref put: inst].
	^ inst.
! !
TestCase subclass: #ArrayLiteralTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler-Tests'!

!ArrayLiteralTest methodsFor: 'as yet unclassified' stamp: 'avi 2/16/2004 21:09'!
tearDown
	self class removeSelector: #array! !

!ArrayLiteralTest methodsFor: 'as yet unclassified' stamp: 'avi 2/16/2004 21:08'!
testReservedIdentifiers
	self class compile: 'array ^ #(nil true false)'.
	self assert: self array = {nil. true. false}.! !

!ArrayLiteralTest methodsFor: 'as yet unclassified' stamp: 'avi 2/16/2004 21:09'!
testSymbols
	self class compile: 'array ^ #(#nil #true #false #''nil'' #''true'' #''false'')'.
	self assert: self array = {#nil. #true. #false. #nil. #true. #false}.! !
ClassTestCase subclass: #ArrayTest
	instanceVariableNames: 'example1'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Arrayed-Tests'!
!ArrayTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class Array. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 
	- http://www.c2.com/cgi/wiki?UnitTest
	- http://minnow.cc.gatech.edu/squeak/1547
	- the sunit class category!


!ArrayTest methodsFor: 'initialize-release' stamp: 'md 4/21/2003 16:29'!
setUp
	example1 := #(1 2 3 4 5).! !


!ArrayTest methodsFor: 'testing' stamp: 'md 4/21/2003 16:36'!
testIsLiteral
	
	self assert: example1 isLiteral.
	example1 at: 1 put: self class.
	self deny: example1 isLiteral.
	example1 at: 1 put: 1.! !
Halt subclass: #AssertionFailure
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Extensions'!
!AssertionFailure commentStamp: 'gh 5/2/2002 20:29' prior: 0!
AsssertionFailure is the exception signaled from Object>>assert: when the assertion block evaluates to false.!

ParseNode subclass: #AssignmentNode
	instanceVariableNames: 'variable value'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
!AssignmentNode commentStamp: '<historical>' prior: 0!
AssignmentNode comment: 'I represent a (var_expr) construct.'!


!AssignmentNode methodsFor: 'initialize-release'!
toDoIncrement: var
	var = variable ifFalse: [^ nil].
	(value isMemberOf: MessageNode) 
		ifTrue: [^ value toDoIncrement: var]
		ifFalse: [^ nil]! !

!AssignmentNode methodsFor: 'initialize-release'!
value
	^ value! !

!AssignmentNode methodsFor: 'initialize-release'!
variable: aVariable value: expression

	variable _ aVariable.
	value _ expression! !

!AssignmentNode methodsFor: 'initialize-release' stamp: 'di 3/22/1999 12:00'!
variable: aVariable value: expression from: encoder

	(aVariable isMemberOf: MessageAsTempNode)
		ifTrue: ["Case of remote temp vars"
				^ aVariable store: expression from: encoder].
	variable _ aVariable.
	value _ expression! !

!AssignmentNode methodsFor: 'initialize-release' stamp: 'hmm 7/15/2001 21:17'!
variable: aVariable value: expression from: encoder sourceRange: range

	encoder noteSourceRange: range forNode: self.
	^self
		variable: aVariable
		value: expression
		from: encoder! !


!AssignmentNode methodsFor: 'code generation' stamp: 'di 9/5/2001 18:46'!
emitForEffect: stack on: aStream

	variable emitLoad: stack on: aStream.
	value emitForValue: stack on: aStream.
	variable emitStorePop: stack on: aStream.
	pc _ aStream position! !

!AssignmentNode methodsFor: 'code generation' stamp: 'di 9/5/2001 21:26'!
emitForValue: stack on: aStream

	variable emitLoad: stack on: aStream.
	value emitForValue: stack on: aStream.
	variable emitStore: stack on: aStream.
	pc _ aStream position! !

!AssignmentNode methodsFor: 'code generation'!
sizeForEffect: encoder

	^(value sizeForValue: encoder)
		+ (variable sizeForStorePop: encoder)! !

!AssignmentNode methodsFor: 'code generation'!
sizeForValue: encoder

	^(value sizeForValue: encoder)
		+ (variable sizeForStore: encoder)! !


!AssignmentNode methodsFor: 'printing' stamp: 'brp 10/8/2003 14:55'!
printOn: aStream indent: level 
	aStream dialect = #SQ00
		ifTrue: [aStream
				withStyleFor: #setOrReturn
				do: [aStream nextPutAll: 'Set '].
			variable printOn: aStream indent: level.
			aStream
				withStyleFor: #setOrReturn
				do: [aStream nextPutAll: ' to '].
			value printOn: aStream indent: level + 2]
		ifFalse: [variable printOn: aStream indent: level.
			aStream
				nextPutAll: (Preferences ansiAssignmentOperatorWhenPrettyPrinting
						ifTrue: [' := ']
						ifFalse: [' _ ']).
			value printOn: aStream indent: level + 2]! !

!AssignmentNode methodsFor: 'printing' stamp: 'di 4/25/2000 13:52'!
printOn: aStream indent: level precedence: p

	(aStream dialect = #SQ00
			ifTrue: [p < 3]
			ifFalse: [p < 4])
		ifTrue: [aStream nextPutAll: '('.
				self printOn: aStream indent: level.
				aStream nextPutAll: ')']
		ifFalse: [self printOn: aStream indent: level]! !


!AssignmentNode methodsFor: 'equation translation'!
variable
	^variable! !


!AssignmentNode methodsFor: 'tiles' stamp: 'RAA 2/26/2001 16:17'!
asMorphicSyntaxIn: parent

	^parent assignmentNode: self variable: variable value: value! !

!AssignmentNode methodsFor: 'tiles' stamp: 'RAA 8/15/1999 16:31'!
explanation

	^'The value of ',value explanation,' is being stored in ',variable explanation
! !


!AssignmentNode methodsFor: '*Tweak-Kedama' stamp: 'yo 10/12/2005 11:32'!
getAllChildren

	^ Array with: variable with: value.
! !

!AssignmentNode methodsFor: '*Tweak-Kedama' stamp: 'yo 10/12/2005 11:32'!
getElderSiblingOf: node

	node = value ifTrue: [^ variable].
	^ nil.
! !

!AssignmentNode methodsFor: '*Tweak-Kedama' stamp: 'yo 10/12/2005 11:32'!
getFirstChild

	^ variable.
! !

!AssignmentNode methodsFor: '*Tweak-Kedama' stamp: 'yo 10/12/2005 11:32'!
getLastChild

	^ value.
! !

!AssignmentNode methodsFor: '*Tweak-Kedama' stamp: 'yo 10/12/2005 11:32'!
isFirstChild: childNode

	^ childNode = variable.
! !

!AssignmentNode methodsFor: '*Tweak-Kedama' stamp: 'yo 10/12/2005 11:32'!
isLastChild: childNode

	^ childNode = value.
! !

!AssignmentNode methodsFor: '*Tweak-Kedama' stamp: 'yo 10/12/2005 11:32'!
replaceNode: childNode with: newNode

	childNode = variable ifTrue: [variable _ newNode. ^ self].
	childNode = value ifTrue: [value _ newNode. ^ self].
! !

!AssignmentNode methodsFor: '*Tweak-Kedama' stamp: 'yo 10/12/2005 11:32'!
visitBy: visitor

	visitor visit: self.
	variable visitBy: visitor.
	value visitBy: visitor.
! !



!AssignmentNode methodsFor: '*Tweak-Kedama-Generated'!
assignmentMsgType
	^ #assignment! !

!AssignmentNode methodsFor: '*Tweak-Kedama-Generated'!
defaultBlockType: t1 
	^ #default! !

!AssignmentNode methodsFor: '*Tweak-Kedama-Generated'!
defaultMessageType
	^ #none! !

!AssignmentNode methodsFor: '*Tweak-Kedama-Generated'!
firstInReceivers: t1 
	^ t1 first! !

!AssignmentNode methodsFor: '*Tweak-Kedama-Generated'!
isStmt: t1 
	^ t1 = #top
		or: [t1 = #condition]! !

!AssignmentNode methodsFor: '*Tweak-Kedama-Generated'!
isTest: t1 parentNode: t2 
	t1
		ifTrue: [^ true].
	^ (t2 isMemberOf: MessageNode)
		and: [t2 receiver = self
				and: [t2 messageType value = #condition]]! !

!AssignmentNode methodsFor: '*Tweak-Kedama-Generated'!
isTopStmt: t1 
	t1 = nil
		ifTrue: [^ true].
	^ false! !

!AssignmentNode methodsFor: '*Tweak-Kedama-Generated'!
rcvr: t1 
	^ t1! !

!AssignmentNode methodsFor: '*Tweak-Kedama-Generated'!
thisNode
	^ self! !

!AssignmentNode methodsFor: '*Tweak-Kedama-Generated'!
transfer: t1 
	^ t1! !


!AssignmentNode methodsFor: '*siss-interface' stamp: 'yo 3/23/2007 20:44'!
sexpWith: aDictionary obj: obj

	| elems |
	elems _ WriteStream on: (Array new: 2).
	elems nextPut: (SExpElement keyword: #variable attributes: (SExpAttributes with: #value->variable key)).
	elems nextPut: (value sexpWith: aDictionary obj: obj).

	^ SExpElement keyword: #assign elements: elems contents.
! !
TileMorph subclass: #AssignmentTileMorph
	instanceVariableNames: 'assignmentRoot assignmentSuffix dataType'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Tiles'!

!AssignmentTileMorph methodsFor: 'arrow' stamp: 'nk 10/8/2004 14:27'!
addArrowsIfAppropriate
	"If the receiver's slot is of an appropriate type, add arrows to the tile."

	(Vocabulary vocabularyForType: dataType)
		ifNotNilDo:
			[:aVocab | aVocab wantsAssignmentTileVariants ifTrue:
				[self addArrows]].
	(assignmentSuffix = ':') ifTrue:
		[ self addMorphBack: (ImageMorph new image: (ScriptingSystem formAtKey: #NewGets)).
		(self findA: StringMorph) ifNotNilDo: [ :sm |
			(sm contents endsWith: ' :') ifTrue: [ sm contents: (sm contents allButLast: 2) ]]]! !


!AssignmentTileMorph methodsFor: 'code generation' stamp: 'sw 2/6/2002 01:17'!
assignmentReceiverTile
	"Answer the TilePadMorph that should be sent storeCodeOn:indent: to get the receiver of the assignment properly stored on the code stream"

	^ owner submorphs first! !

!AssignmentTileMorph methodsFor: 'code generation' stamp: 'sw 2/6/2002 01:25'!
operatorForAssignmentSuffix: aString
	"Answer the operator associated with the receiver, assumed to be one of the compound assignments"

	| toTest |
	toTest _ aString asString.
	#(	('Incr:'				'+')
		('Decr:'				'-')
		('Mult:'				'*'))
	do:
		[:pair | toTest = pair first ifTrue: [^ pair second]].
	^ toTest

	"AssignmentTileMorph new operatorForAssignmentSuffix: 'Incr:'"! !

!AssignmentTileMorph methodsFor: 'code generation' stamp: 'yo 3/2/2007 10:28'!
operatorForSexpAssignmentSuffix: aString
	"Answer the operator associated with the receiver, assumed to be one of the compound assignments"

	| toTest |
	toTest _ aString asString.
	#(	('Incr:'				#Incr:)
		('Decr:'				#Decr:)
		('Mult:'				#Mult:)
		(':'				''))
	do:
		[:pair | toTest = pair first ifTrue: [^ pair second]].
	^ toTest

	"AssignmentTileMorph new operatorForTreeAssignmentSuffix: 'Incr:'"! !

!AssignmentTileMorph methodsFor: 'code generation' stamp: 'yo 4/12/2007 11:44'!
parseNodeWith: encoder

	self error: 'error'.

! !

!AssignmentTileMorph methodsFor: 'code generation' stamp: 'yo 3/15/2007 12:36'!
sexpWith: dictionary

	self error: 'error'.

! !

!AssignmentTileMorph methodsFor: 'code generation' stamp: 'aoy 2/15/2003 21:09'!
storeCodeOn: aStream indent: tabCount 
	"Generate code for an assignment statement.  The code generated looks presentable in the case of simple assignment, though the code generated for the increment/decrement/multiply cases is still the same old assignGetter... sort for now"
aStream nextPutAll: (Utilities setterSelectorFor: assignmentRoot).
			aStream space."Simple assignment, don't need existing value"
	assignmentSuffix = ':' 

		ifFalse: 
			["Assignments that require that old values be retrieved"

			
			self assignmentReceiverTile storeCodeOn: aStream indent: tabCount.
			aStream space.
			aStream nextPutAll: (Utilities getterSelectorFor: assignmentRoot).
			aStream space.
			aStream nextPutAll: (self operatorForAssignmentSuffix: assignmentSuffix).
			aStream space]! !


!AssignmentTileMorph methodsFor: 'initialization' stamp: 'yo 1/30/2005 11:11'!
computeOperatorOrExpression
	"Compute the operator or expression to use, and set the wording correectly on the tile face"

	| aSuffix wording anInterface getter doc |
	operatorOrExpression _ (assignmentRoot, assignmentSuffix) asSymbol.
	aSuffix _ self currentVocabulary translatedWordingFor:  assignmentSuffix.
	getter _ Utilities getterSelectorFor: assignmentRoot.
	anInterface _ self currentVocabulary methodInterfaceAt: getter ifAbsent: [Vocabulary eToyVocabulary methodInterfaceAt: getter ifAbsent: [nil]].
	wording _ anInterface ifNotNil: [anInterface wording] ifNil: [assignmentRoot copyWithout: $:].
	(anInterface notNil and: [(doc _ anInterface documentation) notNil])
		ifTrue:
			[self setBalloonText: doc].
	operatorReadoutString _ wording translated, ' ', aSuffix.
 	self line1: operatorReadoutString.
	self addArrowsIfAppropriate! !

!AssignmentTileMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:44'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	type _ #operator.
	assignmentSuffix _ ':'! !

!AssignmentTileMorph methodsFor: 'initialization' stamp: 'sw 1/17/1999 21:10'!
setAssignmentSuffix: aString
	assignmentSuffix _ aString.
	self computeOperatorOrExpression.
	type _ #operator.
 	self line1: (ScriptingSystem wordingForOperator: operatorOrExpression).
	self addArrowsIfAppropriate; updateLiteralLabel! !

!AssignmentTileMorph methodsFor: 'initialization' stamp: 'yo 1/1/2004 19:50'!
setRoot: aString
	"Establish the assignment root, and update the label on the tile"

	assignmentRoot _ aString.
	self updateLiteralLabel! !

!AssignmentTileMorph methodsFor: 'initialization' stamp: 'sw 2/16/98 01:12'!
setRoot: aString dataType: aSymbol
	assignmentRoot _ aString.
	assignmentSuffix _ ':'.
	dataType _ aSymbol.
	self updateLiteralLabel! !

!AssignmentTileMorph methodsFor: 'initialization' stamp: 'sw 9/12/2001 22:52'!
updateWordingToMatchVocabulary
	"The current vocabulary has changed; change the wording on my face, if appropriate"

	self computeOperatorOrExpression! !


!AssignmentTileMorph methodsFor: 'player viewer' stamp: 'yo 1/1/2004 19:51'!
assignmentRoot
	"Answer the assignment root"

	^ assignmentRoot! !

!AssignmentTileMorph methodsFor: 'player viewer' stamp: 'yo 4/11/2007 21:39'!
assignmentRootForParseNode
	"Answer the assignment root"

	^ Utilities setterSelectorFor: assignmentRoot! !

!AssignmentTileMorph methodsFor: 'player viewer' stamp: 'sw 1/31/98 00:42'!
updateLiteralLabel
	self computeOperatorOrExpression.
	super updateLiteralLabel! !


!AssignmentTileMorph methodsFor: 'accessing' stamp: 'yo 8/30/2006 15:31'!
assignmentSuffix

	^ assignmentSuffix.
! !

!AssignmentTileMorph methodsFor: 'accessing' stamp: 'tak 12/5/2004 14:04'!
options
	^ {#(#: #Incr: #Decr: #Mult: ). {nil. nil. nil. nil}}! !

!AssignmentTileMorph methodsFor: 'accessing' stamp: 'tak 12/5/2004 14:09'!
value
	^ assignmentSuffix! !

!AssignmentTileMorph methodsFor: 'accessing' stamp: 'tak 12/5/2004 14:06'!
value: anObject 
	self setAssignmentSuffix: anObject.
	self acceptNewLiteral! !


!AssignmentTileMorph methodsFor: 'as yet unclassified'!
fixLayoutOfSubmorphsNotIn: aCollection 
	super fixLayoutOfSubmorphsNotIn: aCollection.
	self updateLiteralLabel; updateWordingToMatchVocabulary; layoutChanged; fullBounds! !
LookupKey subclass: #Association
	instanceVariableNames: 'value'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Support'!
!Association commentStamp: '<historical>' prior: 0!
I represent a pair of associated objects--a key and a value. My instances can serve as entries in a dictionary.!


!Association methodsFor: 'accessing'!
key: aKey value: anObject 
	"Store the arguments as the variables of the receiver."

	key _ aKey.
	value _ anObject! !

!Association methodsFor: 'accessing'!
value
	"Answer the value of the receiver."

	^value! !

!Association methodsFor: 'accessing'!
value: anObject 
	"Store the argument, anObject, as the value of the receiver."

	value _ anObject! !


!Association methodsFor: 'printing'!
printOn: aStream

	super printOn: aStream.
	aStream nextPutAll: '->'.
	value printOn: aStream! !

!Association methodsFor: 'printing' stamp: 'MPW 1/4/1901 08:31'!
propertyListOn: aStream
	aStream write:key; print:'='; write:value.
! !

!Association methodsFor: 'printing'!
storeOn: aStream
	"Store in the format (key->value)"
	aStream nextPut: $(.
	key storeOn: aStream.
	aStream nextPutAll: '->'.
	value storeOn: aStream.
	aStream nextPut: $)! !


!Association methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 20:53'!
byteEncode: aStream
	aStream writeAssocation:self.! !


!Association methodsFor: 'objects from disk' stamp: 'tk 10/3/2000 13:03'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  If I am a known global, write a proxy that will hook up with the same resource in the destination system."

	^ (Smalltalk associationAt: key ifAbsent: [nil]) == self 
		ifTrue: [dp _ DiskProxy global: #Smalltalk selector: #associationOrUndeclaredAt: 
							args: (Array with: key).
			refStrm replace: self with: dp.
			dp]
		ifFalse: [self]! !


!Association methodsFor: 'testing' stamp: 'ar 8/14/2001 23:06'!
isSpecialWriteBinding
	"Return true if this variable binding is write protected, e.g., should not be accessed primitively but rather by sending #value: messages"
	^false! !

!Association methodsFor: 'testing' stamp: 'ar 8/14/2001 22:39'!
isVariableBinding
	"Return true if I represent a literal variable binding"
	^true! !


!Association methodsFor: 'comparing' stamp: 'md 1/27/2004 17:27'!
= anAssociation

	^ super = anAssociation and: [value = anAssociation value]! !

!Association methodsFor: 'comparing' stamp: 'md 1/27/2004 17:28'!
hash
	"Hash is reimplemented because = is implemented."
	
	^key hash bitXor: value hash.! !


!Association methodsFor: '*siss-interface' stamp: 'yo 3/23/2007 20:52'!
sissContentsInto: newElem context: dictionary

	| k v |
	k _ key sissElementInContext: dictionary.
	v _ value sissElementInContext: dictionary.
	key sissIsLiteral ifTrue: [
		newElem attributeAt: #keyClass put: key class name.
		newElem attributeAt: #keyValue put: k.
	] ifFalse: [
		newElem attributeAt: #keyId put: (k attributeAt: #idref).
	].
	value sissIsLiteral ifTrue: [
		newElem attributeAt: #valueClass put: value class name.
		newElem attributeAt: #valueValue put: v.
	] ifFalse: [
		newElem attributeAt: #valueId put: (v attributeAt: #idref).
	].
! !


!Association methodsFor: '*DBus-Core' stamp: 'bf 5/25/2007 20:07'!
dbusType
	^ DBusArgument dictEntry! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Association class
	instanceVariableNames: ''!

!Association class methodsFor: 'instance creation' stamp: 'md 12/21/2006 18:03'!
key: newKey value: newValue
	"Answer an instance of me with the arguments as the key and value of 
	the association."

	^ self basicNew key: newKey value: newValue.! !


!Association class methodsFor: '*siss-interface' stamp: 'yo 3/24/2007 08:49'!
sissCreateInstanceFromSexp: sexp idref: idref from: from to: to

	| n k className classObj v e |
	n _ self basicNew.
	idref ifNotNil: [to at: idref put: n].
	sexp attributeAt: #keyId ifPresent: [:id |
		k _self fromSexp: (from at: id asSymbol) from: from to: to.
	] ifAbsent: [
		className _ sexp attributeAt: #keyClass.
		classObj _ self classFromClassName: className.
		e _ SExpElement keyword: className asSymbol attributes: (SExpAttributes with: (#value->(sexp attributeAt: #keyValue))).
		k _ classObj sissCreateInstanceFromSexp: e idref: nil from: from to: to.
	].
	sexp attributeAt: #valueId ifPresent: [:id |
		v _ self fromSexp: (from at: id asSymbol) from: from to: to.
	] ifAbsent: [
		className _ sexp attributeAt: #valueClass.
		classObj _ self classFromClassName: className.
		e _ SExpElement keyword: className asSymbol attributes: (SExpAttributes with: (#value->(sexp attributeAt: #valueValue))).
		v _ classObj sissCreateInstanceFromSexp: e idref: nil from: from to: to.
	].
	^ n key: k value: v.
! !
TestCase subclass: #AssociationTest
	instanceVariableNames: 'a b'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Support-Tests'!

!AssociationTest methodsFor: 'testing' stamp: 'md 3/8/2004 16:37'!
testEquality
	
	self 
		assert: (a key = b key);
		deny: (a value = b value);
		deny: (a = b)

! !

!AssociationTest methodsFor: 'testing' stamp: 'md 3/8/2004 16:38'!
testHash

	self 
		assert: (a hash = a copy hash);
		deny: (a hash = b hash)! !


!AssociationTest methodsFor: 'setup' stamp: 'md 3/8/2004 16:37'!
setUp

	a _ 1 -> 'one'.
	b _ 1 -> 'een'.! !
Object subclass: #AsyncFile
	instanceVariableNames: 'name writeable semaphore fileHandle'
	classVariableNames: 'Busy Error'
	poolDictionaries: ''
	category: 'System-Files'!
!AsyncFile commentStamp: '<historical>' prior: 0!
An asynchronous file allows simple file read and write operations to be performed in parallel with other processing. This is useful in multimedia applications that need to stream large amounts of sound or image data from or to a file while doing other work.
!


!AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primClose: fHandle
	"Close this file. Do nothing if primitive fails."

	<primitive: 'primitiveAsyncFileClose' module: 'AsynchFilePlugin'>
! !

!AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primOpen: fileName forWrite: openForWrite semaIndex: semaIndex
	"Open a file of the given name, and return a handle for that file. Answer the receiver if the primitive succeeds, nil otherwise."

	<primitive: 'primitiveAsyncFileOpen' module: 'AsynchFilePlugin'>
	^ nil
! !

!AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primReadResult: fHandle intoBuffer: buffer at: startIndex count: count
	"Copy the result of the last read operation into the given buffer starting at the given index. The buffer may be any sort of bytes or words object, excluding CompiledMethods. Answer the number of bytes read. A negative result means:
		-1 the last operation is still in progress
		-2 the last operation encountered an error"

	<primitive: 'primitiveAsyncFileReadResult' module: 'AsynchFilePlugin'>
	self primitiveFailed
! !

!AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primReadStart: fHandle fPosition: fPosition count: count
	"Start a read operation of count bytes starting at the given offset in the given file."

	<primitive: 'primitiveAsyncFileReadStart' module: 'AsynchFilePlugin'>
	self error: 'READ THE COMMENT FOR THIS METHOD.'

"NOTE: This method will fail if there is insufficient C heap to allocate an internal buffer of the required size (the value of count).  If you are trying to read a movie file, then the buffer size will be height*width*2 bytes.  Each Squeak image retains a value to be used for this allocation, and it it initially set to 0.  If you are wish to play a 640x480 movie, you need room for a buffer of 640*480*2 = 614400 bytes.  You should execute the following...

	Smalltalk extraVMMemory 2555000.

Then save-and-quit, restart, and try to open the movie file again.  If you are using Async files in another way, find out the value of count when this failure occurs (call it NNNN), and instead of the above, execute...

	Smalltalk extraVMMemory: Smalltalk extraVMMemory + NNNN

then save-and-quit, restart, and try again.
"

! !

!AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primWriteResult: fHandle
	"Answer the number of bytes written. A negative result means:
		-1 the last operation is still in progress
		-2 the last operation encountered an error"

	<primitive: 'primitiveAsyncFileWriteResult' module: 'AsynchFilePlugin'>
	self primitiveFailed
! !

!AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primWriteStart: fHandle fPosition: fPosition fromBuffer: buffer at: startIndex count: count
	"Start a write operation of count bytes starting at the given index in the given buffer. The buffer may be any sort of bytes or words object, excluding CompiledMethods. The contents of the buffer are copied into an internal buffer immediately, so the buffer can be reused after the write operation has been started. Fail if there is insufficient C heap to allocate an internal buffer of the requested size."

	<primitive: 'primitiveAsyncFileWriteStart' module: 'AsynchFilePlugin'>
	writeable ifFalse: [^ self error: 'attempt to write a file opened read-only'].
	self primitiveFailed
! !


!AsyncFile methodsFor: 'as yet unclassified'!
close

	fileHandle ifNil: [^ self].  "already closed"
	self primClose: fileHandle.
	Smalltalk unregisterExternalObject: semaphore.
	semaphore _ nil.
	fileHandle _ nil.
! !

!AsyncFile methodsFor: 'as yet unclassified' stamp: 'di 7/6/1998 10:58'!
fileHandle
	^ fileHandle! !

!AsyncFile methodsFor: 'as yet unclassified' stamp: 'jm 6/25/1998 07:54'!
open: fullFileName forWrite: aBoolean
	"Open a file of the given name, and return a handle for that file. Answer the receiver if the primitive succeeds, nil otherwise.
	If openForWrite is true, then:
		if there is no existing file with this name, then create one
		else open the existing file in read-write mode
	otherwise:
		if there is an existing file with this name, then open it read-only
		else answer nil."
	"Note: if an exisiting file is opened for writing, it is NOT truncated. If truncation is desired, the file should be deleted before being opened as an asynchronous file."
	"Note: On some platforms (e.g., Mac), a file can only have one writer at a time."

	| semaIndex |
	name _ fullFileName.
	writeable _ aBoolean.
	semaphore _ Semaphore new.
	semaIndex _ Smalltalk registerExternalObject: semaphore.
	fileHandle _ self primOpen: name forWrite: writeable semaIndex: semaIndex.
	fileHandle ifNil: [
		Smalltalk unregisterExternalObject: semaphore.
		semaphore _ nil.
		^ nil].
! !

!AsyncFile methodsFor: 'as yet unclassified' stamp: 'jm 6/25/1998 08:28'!
readByteCount: byteCount fromFilePosition: fPosition onCompletionDo: aBlock
	"Start a read operation to read byteCount's from the given position in this file. and fork a process to await its completion. When the operation completes, evaluate the given block. Note that, since the completion block may run asynchronous, the client may need to use a SharedQueue or a semaphore for synchronization."

	| buffer n |
	buffer _ String new: byteCount.
	self primReadStart: fileHandle fPosition: fPosition count: byteCount.
	"here's the process that awaits the results:"
	[
		[	semaphore wait.
		  	n _ self primReadResult: fileHandle intoBuffer: buffer at: 1 count: byteCount.
		  	n = Busy.
		] whileTrue.  "loop while busy in case the semaphore had excess signals"
		n = Error ifTrue: [^ self error: 'asynchronous read operation failed'].
		aBlock value: buffer.
	] forkAt: Processor userInterruptPriority.
! !

!AsyncFile methodsFor: 'as yet unclassified' stamp: 'JMM 11/24/2001 17:23'!
test: byteCount fileName: fileName
	"AsyncFile new test: 10000 fileName: 'testData'"

	| buf1 buf2 bytesWritten bytesRead |
	buf1 _ String new: byteCount withAll: $x.
	buf2 _ String new: byteCount.
	self open: ( FileDirectory default fullNameFor: fileName) forWrite: true.
	self primWriteStart: fileHandle
		fPosition: 0
		fromBuffer: buf1
		at: 1
		count: byteCount.
	semaphore wait.
	bytesWritten _ self primWriteResult: fileHandle.
	self close.
	
	self open: ( FileDirectory default fullNameFor: fileName) forWrite: false.
	self primReadStart: fileHandle fPosition: 0 count: byteCount.
	semaphore wait.
	bytesRead _
		self primReadResult: fileHandle
			intoBuffer: buf2
			at: 1
			count: byteCount.
	self close.

	buf1 = buf2 ifFalse: [self error: 'buffers do not match'].
	^ 'wrote ', bytesWritten printString, ' bytes; ',
	   'read ', bytesRead printString, ' bytes'
! !

!AsyncFile methodsFor: 'as yet unclassified' stamp: 'di 7/6/1998 10:58'!
waitForCompletion
	semaphore wait! !

!AsyncFile methodsFor: 'as yet unclassified' stamp: 'jm 6/25/1998 17:28'!
writeBuffer: buffer atFilePosition: fPosition onCompletionDo: aBlock
	"Start an operation to write the contents of the buffer at given position in this file, and fork a process to await its completion. When the write completes, evaluate the given block. Note that, since the completion block runs asynchronously, the client may need to use a SharedQueue or a semaphore for synchronization."

	| n |
	self primWriteStart: fileHandle
		fPosition: fPosition
		fromBuffer: buffer
		at: 1
		count: buffer size.
	"here's the process that awaits the results:"
	[
		[	semaphore wait.
		  	n _ self primWriteResult: fileHandle.
		  	n = Busy.
		] whileTrue.  "loop while busy in case the semaphore had excess signals"
		n = Error ifTrue: [^ self error: 'asynchronous write operation failed'].
		n = buffer size ifFalse: [^ self error: 'did not write the entire buffer'].
		aBlock value.
	] forkAt: Processor userInterruptPriority.
! !


!AsyncFile methodsFor: '*sugar' stamp: 'bf 9/19/2006 22:04'!
readChar
	"Read one char. Might block."
	^(self readChars: 1) first
! !

!AsyncFile methodsFor: '*sugar' stamp: 'bf 9/19/2006 22:33'!
readChars: count
	"Read count chars. Might block."

	| buffer n |
	fileHandle ifNil: [^ self error: 'file closed'].
	buffer := String new: count.
	self primReadStart: fileHandle fPosition: -1 count: buffer size.
	[	semaphore wait.
		n := self primReadResult: fileHandle intoBuffer: buffer at: 1 count: buffer size.
		n = Busy.
	] whileTrue.  "loop while busy in case the semaphore had excess signals"
	n = Error ifTrue: [^ self error: 'asynchronous read operation failed'].
	^buffer! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AsyncFile class
	instanceVariableNames: ''!

!AsyncFile class methodsFor: 'class initialization' stamp: 'jm 6/25/1998 17:33'!
initialize
	"AsyncFile initialize"

	"Possible abnormal I/O completion results."
	Busy _ -1.
	Error _ -2.
! !
EllipseMorph subclass: #AtomMorph
	instanceVariableNames: 'velocity'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!
!AtomMorph commentStamp: 'tbn 11/25/2004 09:06' prior: 0!
AtomMorph represents an atom used in the simulation of
an ideal gas. It's container is typically a BouncingAtomsMorph.

Try:

	BouncingAtomsMorph  new openInWorld

to open the gas simulation or:

	AtomMorph example

to open an instance in the current world!


!AtomMorph methodsFor: 'accessing'!
infected

	^ color = Color red! !

!AtomMorph methodsFor: 'accessing'!
infected: aBoolean

	aBoolean
		ifTrue: [self color: Color red]
		ifFalse: [self color: Color blue].! !

!AtomMorph methodsFor: 'accessing'!
velocity

	^ velocity! !

!AtomMorph methodsFor: 'accessing'!
velocity: newVelocity

	velocity _ newVelocity.! !


!AtomMorph methodsFor: 'drawing'!
drawOn: aCanvas
	"Note: Set 'drawAsRect' to true to make the atoms draw faster. When testing the speed of other aspects of Morphic, such as its damage handling efficiency for large numbers of atoms, it is useful to make drawing faster."

	| drawAsRect |
	drawAsRect _ false.  "rectangles are faster to draw"
	drawAsRect
		ifTrue: [aCanvas fillRectangle: self bounds color: color]
		ifFalse: [super drawOn: aCanvas].! !


!AtomMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:13'!
defaultBorderWidth
"answer the default border width for the receiver"
	^ 0! !

!AtomMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:13'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color blue! !

!AtomMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:13'!
initialize
	"Make a new atom with a random position and velocity."
	super initialize.
""
	self extent: 8 @ 7.
	
	self
		randomPositionIn: (0 @ 0 corner: 300 @ 300)
		maxVelocity: 10! !

!AtomMorph methodsFor: 'initialization' stamp: 'RAA 12/15/2000 07:32'!
randomPositionIn: aRectangle maxVelocity: maxVelocity
	"Give this atom a random position and velocity."

	| origin extent |
	origin _ aRectangle origin.
	extent _ (aRectangle extent - self bounds extent) rounded.
	self position:
		(origin x + extent x atRandom) @
		(origin y + extent y atRandom).
	velocity _
		(maxVelocity - (2 * maxVelocity) atRandom) @
		(maxVelocity - (2 * maxVelocity) atRandom).
! !


!AtomMorph methodsFor: 'private' stamp: 'jm 8/10/1998 17:40'!
bounceIn: aRect
	"Move this atom one step along its velocity vector and make it bounce if it goes outside the given rectangle. Return true if it is bounced."

	| p vx vy px py bounced |
	p _ self position.
	vx _ velocity x.		vy _ velocity y.
	px _ p x + vx.		py _ p y + vy.
	bounced _ false.
	px > aRect right ifTrue: [
		px _ aRect right - (px - aRect right).
		vx _ velocity x negated.
		bounced _ true].
	py > aRect bottom ifTrue: [
		py _  aRect bottom - (py - aRect bottom).
		vy _ velocity y negated.
		bounced _ true].
	px < aRect left ifTrue: [
		px _ aRect left - (px - aRect left).
		vx _ velocity x negated.
		bounced _ true].
	py < aRect top ifTrue: [
		py _  aRect top - (py - aRect top).
		vy _ velocity y negated.
		bounced _ true].
	self position: px @ py.
	bounced ifTrue: [self velocity: vx @ vy].
	^ bounced
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AtomMorph class
	instanceVariableNames: ''!

!AtomMorph class methodsFor: 'new-morph participation' stamp: 'di 6/22/97 09:07'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !


!AtomMorph class methodsFor: 'examples' stamp: 'tbn 11/25/2004 09:03'!
example
	"
	AtomMorph example
	"
	|a|
	a := AtomMorph new openInWorld. 
	a color: Color random.
 	[1000 timesRepeat:  [a bounceIn: World bounds.  (Delay forMilliseconds: 50) wait]. 
	 a delete] fork.! !
ClassTestCase subclass: #AtomMorphTest
	instanceVariableNames: 'morph'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo-Tests'!
!AtomMorphTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class AtomMorph. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 
	- http://www.c2.com/cgi/wiki?UnitTest
	- http://minnow.cc.gatech.edu/squeak/1547
	- the sunit class category!


!AtomMorphTest methodsFor: 'initialize-release' stamp: 'md 4/17/2003 19:03'!
setUp
	
	morph := AtomMorph new.! !

!AtomMorphTest methodsFor: 'initialize-release' stamp: 'md 4/17/2003 19:03'!
tearDown
	morph delete.! !


!AtomMorphTest methodsFor: 'testing ' stamp: 'md 4/17/2003 19:06'!
testVelocity
	morph velocity: 0@0.
	self assert: ( (morph velocity) = (0@0) ).! !
Error subclass: #AttemptToWriteReadOnlyGlobal
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Kernel'!
!AttemptToWriteReadOnlyGlobal commentStamp: 'gh 5/2/2002 20:26' prior: 0!
This is a resumable error you get if you try to assign a readonly variable a value.
Name definitions in the module system can be read only and are then created using instances of ReadOnlyVariableBinding instead of Association.
See also LookupKey>>beReadWriteBinding and LookupKey>>beReadOnlyBinding.

!


!AttemptToWriteReadOnlyGlobal methodsFor: 'as yet unclassified' stamp: 'ar 8/17/2001 18:02'!
description
	"Return a textual description of the exception."

	| desc mt |
	desc := 'Error'.
	^(mt := self messageText) == nil
		ifTrue: [desc]
		ifFalse: [desc, ': ', mt]! !

!AttemptToWriteReadOnlyGlobal methodsFor: 'as yet unclassified' stamp: 'ar 8/17/2001 18:02'!
isResumable
	^true! !
Stream subclass: #AttributedTextStream
	instanceVariableNames: 'characters attributeRuns attributeValues currentAttributes currentRun'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!
!AttributedTextStream commentStamp: '<historical>' prior: 0!
a stream on Text's which keeps track of the last attribute put; new characters are added with those attributes.

instance vars:

	characters - a WriteStream of the characters in the stream
	attributeRuns - a RunArray with the attributes for the stream
	currentAttributes - the attributes to be used for new text
	attributesChanged - whether the attributes have changed since the last addition!


!AttributedTextStream methodsFor: 'retrieving the text' stamp: 'ar 10/16/2001 22:39'!
contents
	| ans |
	currentRun > 0 ifTrue:[
		attributeValues nextPut: currentAttributes.
		attributeRuns nextPut: currentRun.
		currentRun _ 0].
	ans _ Text new: characters size.
	"this is declared private, but it's exactly what I need, and it's declared as exactly what I want it to do...."
	ans setString: characters contents  setRuns: 
		(RunArray runs: attributeRuns contents values: attributeValues contents).
	^ans! !


!AttributedTextStream methodsFor: 'stream protocol' stamp: 'ar 10/16/2001 22:38'!
nextPut: aChar
	currentRun _ currentRun + 1.
	characters nextPut: aChar! !

!AttributedTextStream methodsFor: 'stream protocol' stamp: 'ar 10/16/2001 22:38'!
nextPutAll: aString
	"add an entire string with the same attributes"
	currentRun _ currentRun + aString size.
	characters nextPutAll: aString.! !


!AttributedTextStream methodsFor: 'access' stamp: 'ls 6/27/1998 15:09'!
currentAttributes
	"return the current attributes"
	^currentAttributes! !

!AttributedTextStream methodsFor: 'access' stamp: 'ar 10/16/2001 22:57'!
currentAttributes: newAttributes
	"set the current attributes"
	(currentRun > 0 and:[currentAttributes ~= newAttributes]) ifTrue:[
		attributeRuns nextPut: currentRun.
		attributeValues nextPut: currentAttributes.
		currentRun _ 0.
	].
	currentAttributes _ newAttributes.
! !

!AttributedTextStream methodsFor: 'access' stamp: 'ls 9/10/1998 03:36'!
size
	"number of characters in the stream so far"
	^characters size! !


!AttributedTextStream methodsFor: 'private-initialization' stamp: 'ar 10/16/2001 22:40'!
initialize
	characters _ WriteStream on: String new.
	currentAttributes _ OrderedCollection new.
	currentRun _ 0.
	attributeValues _ WriteStream on: (Array new: 50).
	attributeRuns _ WriteStream on: (Array new: 50).	! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AttributedTextStream class
	instanceVariableNames: ''!

!AttributedTextStream class methodsFor: 'instance creation' stamp: 'gk 2/9/2004 18:50'!
new
	"For this class we override Stream class>>new since this
	class actually is created using #new, even though it is a Stream."
	
	^self basicNew initialize! !
Object subclass: #AttributeSemanticRule
	instanceVariableNames: 'inputSpecs output selector ruleText'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tweak-Kedama-ParseTreeTransformer'!

!AttributeSemanticRule methodsFor: 'all' stamp: 'yo 5/18/2005 15:40'!
inputSpecs

	^ inputSpecs.
! !

!AttributeSemanticRule methodsFor: 'all' stamp: 'yo 6/4/2005 19:59'!
inputSpecs: inputs

	inputSpecs _ inputs.
! !

!AttributeSemanticRule methodsFor: 'all' stamp: 'yo 5/17/2005 23:06'!
output

	^ output.
! !

!AttributeSemanticRule methodsFor: 'all' stamp: 'yo 5/17/2005 23:08'!
output: attr

	output _ attr.
! !

!AttributeSemanticRule methodsFor: 'all' stamp: 'yo 5/20/2005 17:49'!
printOn: aStream

	aStream nextPutAll: 'Rule(';
		nextPutAll: output grammarClass name; 
		nextPut: $.;
		nextPutAll: output attributeName;
		nextPutAll: ' _ ';
		nextPutAll: (selector ifNil: ['nil']);
		nextPut: $(.
	inputSpecs do: [:in |
		in printOn: aStream
	].
	aStream nextPutAll: '))'.
! !

!AttributeSemanticRule methodsFor: 'all' stamp: 'yo 5/17/2005 23:06'!
ruleText

	^ ruleText.
! !

!AttributeSemanticRule methodsFor: 'all' stamp: 'yo 5/21/2005 20:36'!
ruleText: text

	ruleText _ text.
! !

!AttributeSemanticRule methodsFor: 'all' stamp: 'yo 5/20/2005 17:06'!
selector

	^ selector.
! !

!AttributeSemanticRule methodsFor: 'all' stamp: 'yo 5/21/2005 20:37'!
selector: aSymbol

	selector _ aSymbol.

! !

!AttributeSemanticRule methodsFor: 'all' stamp: 'yo 5/21/2005 19:30'!
shouldBundleArgs

	^ inputSpecs size = 1 and: [inputSpecs first type = #allChildrenSynth].
! !
Object subclass: #AttributeVisitor
	instanceVariableNames: 'tree attributes evaluator allOccurences'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tweak-Kedama-ParseTreeTransformer'!

!AttributeVisitor methodsFor: 'all' stamp: 'yo 1/14/2006 12:51'!
allOccurences

	^ allOccurences.
! !

!AttributeVisitor methodsFor: 'all' stamp: 'yo 1/14/2006 13:45'!
newWith: aParseTree for: anEvaluator

	attributes _ IdentityDictionary new.
	allOccurences _ WriteStream on: (Array new: 1000).
	tree _ aParseTree.
	evaluator _ anEvaluator.
	tree visitBy: self.
! !

!AttributeVisitor methodsFor: 'all' stamp: 'yo 6/11/2005 15:45'!
tree

	^ tree.
! !

!AttributeVisitor methodsFor: 'all' stamp: 'yo 3/1/2006 22:17'!
visit: node

	| defs occurence ocs |
	defs _ evaluator attributeDefinitionsOf: node class.
	ocs _ OrderedCollection new.
	defs do: [:def |
		occurence _ ParseNodeAttributeOccurence new
			attributeName: def attributeName;
			rawGetter: def rawGetter;
			setter: def setter;
			grammarClass: node class;
			addRules: def rules;
			type: def type;
			node: node.
		node perform: def setter with: occurence.
		ocs add: occurence.
		allOccurences nextPut: occurence.
	].
	node xxxOccurences: ocs.! !


!AttributeVisitor methodsFor: 'debugging' stamp: 'yo 8/31/2006 16:44'!
occurencesForAttribute: attrName

	^ allOccurences contents select: [:e | e attributeName = attrName].
! !

!AttributeVisitor methodsFor: 'debugging' stamp: 'yo 8/31/2006 22:28'!
occurencesForNodeClass: aParseNodeClass

	^ allOccurences contents select: [:e | e node class = aParseNodeClass].
! !

!AttributeVisitor methodsFor: 'debugging' stamp: 'yo 8/31/2006 16:44'!
occurencesForNode: aParseNode

	^ allOccurences contents select: [:e | e node = aParseNode].
! !
EToyCommunicatorMorph subclass: #AudioChatGUI
	instanceVariableNames: 'mycodec myrecorder mytargetip myalert playOnArrival theConnectButton soundBlockNumber soundMessageID queueForMultipleSends transmitWhileRecording theTalkButton handsFreeTalking handsFreeTalkingFlashTime'
	classVariableNames: 'DebugLog LiveMessages NewAudioMessages PlayOnArrival'
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Collaborative'!

!AudioChatGUI methodsFor: 'initialization' stamp: 'RAA 8/2/2000 16:33'!
buttonColor 

	^Color lightBrown! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'yo 12/14/2007 17:24'!
connectButton
	
	^SimpleButtonMorph new
		label: 'Connect' font: Preferences standardButtonFont;
		color: self buttonColor;
		target: self;
		actWhen: #buttonUp;
		actionSelector: #connect;
		setBalloonText: 'Press to connect to another audio chat user.'

! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 4! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color yellow! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:48'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	transmitWhileRecording _ false.
	handsFreeTalking _ false.
	mycodec _ GSMCodec new.
	myrecorder _ ChatNotes new.
	mytargetip _ ''.
	
	self start2.
	self changeTalkButtonLabel! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'RAA 8/4/2000 14:26'!
ipAddress: aString

	mytargetip _ aString! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'yo 12/14/2007 21:41'!
messageWaitingAlertIndicator

	| messageCounter |
	myalert _ AlertMorph new socketOwner: self.
	messageCounter _ UpdatingStringMorph on: self selector: #objectsInQueue.
	messageCounter font: Preferences standardEToysFont.
	myalert addMorph: messageCounter.
	messageCounter contents: '0'; color: Color white.
	messageCounter align: messageCounter center with: myalert center.
	myalert setBalloonText: 'New messages indicator. This will flash and show the number of messages when there are messages that you haven''t listened to. You can click here to play the next message.'.

	myalert on: #mouseUp send: #playNextMessage to: self.
	^myalert! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'yo 12/14/2007 17:24'!
playButton

	^SimpleButtonMorph new
		label: 'Play' font: Preferences standardButtonFont;
		color: self buttonColor;
		target: self;
		actWhen: #buttonUp;
		actionSelector: #playNextMessage;
		setBalloonText: 'Play the next new message.'

! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'RAA 8/2/2000 16:37'!
recordAndStopButton

	^ChatButtonMorph new
		labelUp: 'Record';
		labelDown: 'RECORDING';
		label: 'Record';
		color: self buttonColor;
		target: self;
		actionUpSelector: #stop;
		actionDownSelector: #record;
		setBalloonText: 'Press and hold to record a message. It will be sent when you release the mouse.'
! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'yo 12/14/2007 22:02'!
start2

	Socket initializeNetwork.
	myrecorder initialize.

	self addARow: {
		self inAColumn: {
			(
				self inARow: {
					self inAColumn: {self toggleForSendWhileTalking}.
					self inAColumn: {self toggleForHandsFreeTalking}.
					self inAColumn: {self toggleForPlayOnArrival}.
				}
			) hResizing: #shrinkWrap.
			self inARow: {
				self talkBacklogIndicator.
				(Morph new color: Color transparent; extent: 8@0).
				self messageWaitingAlertIndicator.
			}.
		}.
		self inAColumn: {
			theConnectButton _ self connectButton.
			self playButton.
			theTalkButton _ self talkButton.
		}.
	}.
! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'yo 12/14/2007 21:41'!
talkBacklogIndicator

	^(UpdatingStringMorph on: self selector: #talkBacklog)
		font: Preferences standardEToysFont;
		setBalloonText: 'Approximate number of seconds of delay in your messages getting to the other end.'! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'RAA 8/7/2000 06:52'!
talkButton

	^ChatButtonMorph new
		labelUp: 'xxx';
		labelDown: 'xxx';
		label: 'xxx';
		color: self buttonColor;
		target: self;
		actionUpSelector: #talkButtonUp;
		actionDownSelector: #talkButtonDown;
		setBalloonText: 'xxx'
! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'RAA 8/12/2000 16:14'!
toggleForHandsFreeTalking

	^self
		simpleToggleButtonFor: self 
		attribute: #handsFreeTalking 
		help: 'Whether you want to talk without holding the mouse down.'! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'RAA 8/12/2000 16:15'!
toggleForPlayOnArrival

	^self
		simpleToggleButtonFor: self 
		attribute: #playOnArrival 
		help: 'Whether you want to play messages automatically on arrival.'! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'RAA 8/12/2000 16:14'!
toggleForSendWhileTalking

	^self
		simpleToggleButtonFor: self 
		attribute: #transmitWhileRecording 
		help: 'Whether you want to send messages while recording.'! !


!AudioChatGUI methodsFor: 'sending' stamp: 'RAA 8/6/2000 18:25'!
handsFreeTalking

	^handsFreeTalking ifNil: [handsFreeTalking _ false].! !

!AudioChatGUI methodsFor: 'sending' stamp: 'RAA 8/6/2000 09:47'!
record

	queueForMultipleSends _ nil.
	myrecorder record.! !

!AudioChatGUI methodsFor: 'sending' stamp: 'RAA 8/12/2000 15:01'!
samplingRateForTransmission

	^11025		"try to cut down on amount of data sent for live chats"! !

!AudioChatGUI methodsFor: 'sending' stamp: 'RAA 8/13/2000 11:44'!
send

	| null rawSound aSampledSound |

	mytargetip isEmpty ifTrue: [
		^self inform: 'You must connect with someone first.'.
	].
	rawSound _ myrecorder recorder recordedSound ifNil: [^self].
	aSampledSound _ rawSound asSampledSound.
"Smalltalk at: #Q3 put: {rawSound. rawSound asSampledSound. aCompressedSound}."
	self transmitWhileRecording ifTrue: [
		self sendOneOfMany: rawSound asSampledSound.
		queueForMultipleSends ifNotNil: [queueForMultipleSends nextPut: nil].
		queueForMultipleSends _ nil.
		^self
	].

	null _ String with: 0 asCharacter.
	EToyPeerToPeer new 
		sendSomeData: {
			EToyIncomingMessage typeAudioChat,null. 
			Preferences defaultAuthorName,null.
			aSampledSound originalSamplingRate asInteger printString,null.
			(mycodec compressSound: aSampledSound) channels first.
		}
		to: mytargetip
		for: self.

! !

!AudioChatGUI methodsFor: 'sending' stamp: 'RAA 8/12/2000 14:34'!
sendAnyCompletedSounds

	| soundsSoFar firstCompleteSound |

	myrecorder isRecording ifFalse: [^self].
	mytargetip isEmpty ifTrue: [^self].
	soundsSoFar _ myrecorder recorder recordedSound ifNil: [^self].
	firstCompleteSound _ soundsSoFar removeFirstCompleteSoundOrNil ifNil: [^self].
	self sendOneOfMany: firstCompleteSound.! !

!AudioChatGUI methodsFor: 'sending' stamp: 'RAA 8/12/2000 18:22'!
sendOneOfMany: aSampledSound

	| null message aCompressedSound ratio resultBuf oldSamples newCount t fromIndex val maxVal |

	self samplingRateForTransmission = aSampledSound originalSamplingRate ifTrue: [
		aCompressedSound _ mycodec compressSound: aSampledSound.
	] ifFalse: [
		t _ [
			ratio _ aSampledSound originalSamplingRate // self samplingRateForTransmission.
			oldSamples _ aSampledSound samples.
			newCount _ oldSamples monoSampleCount // ratio.
			resultBuf _ SoundBuffer newMonoSampleCount: newCount.
			fromIndex _ 1.
			maxVal _ 0.
			1 to: newCount do: [ :i |
				maxVal _ maxVal max: (val _ oldSamples at: fromIndex).
				resultBuf at: i put: val.
				fromIndex _ fromIndex + ratio.
			].
		] timeToRun.
		NebraskaDebug at: #soundReductionTime add: {t. maxVal}.
		maxVal < 400 ifTrue: [
			NebraskaDebug at: #soundReductionTime add: {'---dropped---'}.
			^self
		].		"awfully quiet"
		aCompressedSound _ mycodec compressSound: (
			SampledSound new 
				setSamples: resultBuf 
				samplingRate: aSampledSound originalSamplingRate // ratio
		).
	].

	null _ String with: 0 asCharacter.
	message _ {
		EToyIncomingMessage typeAudioChatContinuous,null. 
		Preferences defaultAuthorName,null.
		aCompressedSound samplingRate asInteger printString,null.
		aCompressedSound channels first.
	}.
	queueForMultipleSends ifNil: [
		queueForMultipleSends _ EToyPeerToPeer new 
			sendSomeData: message
			to: mytargetip
			for: self
			multiple: true.
	] ifNotNil: [
		queueForMultipleSends nextPut: message
	].

! !

!AudioChatGUI methodsFor: 'sending' stamp: 'RAA 8/12/2000 16:18'!
talkBacklog

	^(queueForMultipleSends ifNil: [^0]) size // 2! !

!AudioChatGUI methodsFor: 'sending' stamp: 'RAA 8/9/2000 18:05'!
talkButtonDown

	EToyListenerMorph confirmListening.
	self handsFreeTalking ifFalse: [^self record].
	theTalkButton label: 'Release'.
! !

!AudioChatGUI methodsFor: 'sending' stamp: 'RAA 8/9/2000 18:13'!
talkButtonUp

	theTalkButton recolor: self buttonColor.
	self handsFreeTalking ifFalse: [^self stop].
	myrecorder isRecording ifTrue: [
		theTalkButton label: 'Talk'.
		^self stop.
	].
	self record.
	theTalkButton label: 'TALKING'.


! !

!AudioChatGUI methodsFor: 'sending' stamp: 'RAA 8/6/2000 13:08'!
transmitWhileRecording

	^transmitWhileRecording ifNil: [transmitWhileRecording _ false]! !


!AudioChatGUI methodsFor: 'stepping and presenter' stamp: 'RAA 8/4/2000 14:05'!
start

	| myUpdatingText playButton myOpenConnectionButton myStopButton window  |
"
--- old system window version ---
"
	Socket initializeNetwork.
	myrecorder initialize.

	window _ (SystemWindow labelled: 'iSCREAM') model: self.

	myalert _ AlertMorph new.
	myalert socketOwner: self.
	window addMorph: myalert frame: (0.35@0.4 corner: 0.5@0.7).

	(playButton _ self playButton) center: 200@300.
	window addMorph: playButton frame: (0.5@0.4 corner: 1.0@0.7).

	(myOpenConnectionButton _ self connectButton) center: 250@300.
	window addMorph: myOpenConnectionButton frame: (0.5@0 corner: 1.0@0.4).

	(myStopButton _ self recordAndStopButton) center: 300@300.
	window addMorph: myStopButton frame: (0.5@0.7 corner: 1.0@1.0).

	myUpdatingText _ UpdatingStringMorph on: self selector: #objectsInQueue.
	window addMorph: myUpdatingText frame: (0.41@0.75 corner: 0.45@0.95).

	"myUserList init."! !

!AudioChatGUI methodsFor: 'stepping and presenter' stamp: 'RAA 8/12/2000 18:11'!
step

	| now |
	super step.
	self transmitWhileRecording ifTrue: [self sendAnyCompletedSounds].
	self handsFreeTalking & myrecorder isRecording ifTrue: [
		now _ Time millisecondClockValue.
		((handsFreeTalkingFlashTime ifNil: [0]) - now) abs > 200 ifTrue: [
			theTalkButton color: (
				theTalkButton color = self buttonColor 
						ifTrue: [Color white] 
						ifFalse: [self buttonColor]
			).
			handsFreeTalkingFlashTime _ now.
		].
	].
	self class playOnArrival ifTrue: [self playNextMessage].

	"myrecorder ifNotNil: [
		myrecorder recorder samplingRate printString ,'   ',
		SoundPlayer samplingRate printString,'    '

		displayAt: 0@0
	]."! !

!AudioChatGUI methodsFor: 'stepping and presenter' stamp: 'Tbp 4/11/2000 16:49'!
stop

	myrecorder stop.
	self send.! !


!AudioChatGUI methodsFor: 'stuff' stamp: 'aoy 2/17/2003 01:01'!
changeTalkButtonLabel
	| bText |
	self transmitWhileRecording.
	handsFreeTalking 
		ifTrue: 
			[theTalkButton
				labelUp: 'Talk';
				labelDown: 'Release';
				label: 'Talk'.
			bText := 'Click once to begin a message. Click again to end the message.']
		ifFalse: 
			[theTalkButton
				labelUp: 'Talk';
				labelDown: (transmitWhileRecording 
							ifTrue: ['TALKING']
							ifFalse: ['RECORDING']);
				label: 'Talk'.
			bText := 'Press and hold to record a message.'].
	bText := transmitWhileRecording 
		ifTrue: [bText , ' The message will be sent while you are speaking.']
		ifFalse: [bText , ' The message will be sent when you are finished.'].
	theTalkButton setBalloonText: bText! !

!AudioChatGUI methodsFor: 'stuff' stamp: 'mir 6/17/2007 20:03'!
connect

	| address |
	mytargetip := FillInTheBlank 
		request: 'Connect to?' 
		initialAnswer: (mytargetip ifNil: ['']).
	mytargetip := (address := NetNameResolver addressForName: mytargetip)
		ifNil: ['']
		ifNotNil: [address hostNumber]! !

!AudioChatGUI methodsFor: 'stuff' stamp: 'RAA 8/4/2000 13:09'!
currentConnectionStateString

	^'?'
! !

!AudioChatGUI methodsFor: 'stuff' stamp: 'RAA 8/6/2000 18:27'!
getChoice: aSymbol

	aSymbol == #playOnArrival ifTrue: [^self class playOnArrival].
	aSymbol == #transmitWhileRecording ifTrue: [^self transmitWhileRecording].
	aSymbol == #handsFreeTalking ifTrue: [^self handsFreeTalking].

! !

!AudioChatGUI methodsFor: 'stuff' stamp: 'RAA 8/4/2000 13:01'!
objectsInQueue

	^self class numberOfNewMessages! !

!AudioChatGUI methodsFor: 'stuff' stamp: 'RAA 8/4/2000 12:26'!
playNextMessage

	self class playNextAudioMessage.
! !

!AudioChatGUI methodsFor: 'stuff' stamp: 'RAA 8/4/2000 14:59'!
removeConnectButton

	theConnectButton ifNotNil: [
		theConnectButton delete.
		theConnectButton _ nil.
	].! !

!AudioChatGUI methodsFor: 'stuff' stamp: 'RAA 8/7/2000 06:52'!
toggleChoice: aSymbol

	aSymbol == #playOnArrival ifTrue: [
		^PlayOnArrival _ self class playOnArrival not
	].
	aSymbol == #transmitWhileRecording ifTrue: [
		transmitWhileRecording _ self transmitWhileRecording not.
		self changeTalkButtonLabel.
		^transmitWhileRecording
	].
	aSymbol == #handsFreeTalking ifTrue: [
		handsFreeTalking _ self handsFreeTalking not.
		self changeTalkButtonLabel.
		^handsFreeTalking
	].


! !


!AudioChatGUI methodsFor: 'testing' stamp: 'RAA 8/12/2000 18:09'!
stepTime

	myrecorder ifNil: [^200].
	myrecorder isRecording ifFalse: [^200].
	^20! !

!AudioChatGUI methodsFor: 'testing' stamp: 'RAA 8/2/2000 07:47'!
stepTimeIn: aSystemWindow

	^self stepTime
! !


!AudioChatGUI methodsFor: 'user interface' stamp: 'TBP 3/5/2000 16:22'!
defaultBackgroundColor
	"In a better design, this would be handled by preferences."
	^Color yellow."r: 1.0 g: 0.7 b: 0.8"! !

!AudioChatGUI methodsFor: 'user interface' stamp: 'TBP 3/5/2000 16:02'!
initialExtent
	"Nice and small--that was the idea.
	It shouldn't take up much screen real estate."
	^200@100! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AudioChatGUI class
	instanceVariableNames: ''!

!AudioChatGUI class methodsFor: 'as yet unclassified' stamp: 'RAA 8/9/2000 16:12'!
debugLog: x
"
AudioChatGUI debugLog: nil
AudioChatGUI debugLog: OrderedCollection new
DebugLog LiveMessages NewAudioMessages PlayOnArrival 
"
	DebugLog _ x.
! !

!AudioChatGUI class methodsFor: 'as yet unclassified' stamp: 'RAA 8/11/2000 11:54'!
handleNewAudioChat2From: dataStream sentBy: senderName ipAddress: ipAddressString

	| newSound seqSound compressed |

	compressed _ self newCompressedSoundFrom: dataStream.
	newSound _ compressed asSound.
"-------an experiment to try
newSound adjustVolumeTo: 7.0 overMSecs: 10
--------"
DebugLog ifNotNil: [
	DebugLog add: {compressed. newSound}.
].
	LiveMessages ifNil: [LiveMessages _ Dictionary new].
	seqSound _ LiveMessages at: ipAddressString ifAbsentPut: [SequentialSound new].
	seqSound isPlaying ifTrue: [
		seqSound
			add: newSound;
			pruneFinishedSounds.
	] ifFalse: [
		seqSound
			initialize;
			add: newSound.
	].
	seqSound isPlaying ifFalse: [seqSound play].! !

!AudioChatGUI class methodsFor: 'as yet unclassified' stamp: 'RAA 8/9/2000 19:28'!
handleNewAudioChatFrom: dataStream sentBy: senderName ipAddress: ipAddressString

	| compressed |

	compressed _ self newCompressedSoundFrom: dataStream.
DebugLog ifNotNil: [
	DebugLog add: {compressed}.
].

	self newAudioMessages nextPut: compressed.
	self playOnArrival ifTrue: [self playNextAudioMessage].
	
! !

!AudioChatGUI class methodsFor: 'as yet unclassified' stamp: 'RAA 8/4/2000 12:16'!
newAudioMessages

	^NewAudioMessages ifNil: [NewAudioMessages _ SharedQueue new].! !

!AudioChatGUI class methodsFor: 'as yet unclassified' stamp: 'RAA 8/9/2000 19:28'!
newCompressedSoundFrom: dataStream

	| samplingRate |

	samplingRate _ (dataStream upTo: 0 asCharacter) asNumber.
	^CompressedSoundData new 
		withEToySound: dataStream upToEnd
		samplingRate: samplingRate.
! !

!AudioChatGUI class methodsFor: 'as yet unclassified' stamp: 'RAA 8/4/2000 13:01'!
numberOfNewMessages

	^self newAudioMessages size! !

!AudioChatGUI class methodsFor: 'as yet unclassified' stamp: 'RAA 8/6/2000 14:23'!
playNextAudioMessage

	(self newAudioMessages nextOrNil ifNil: [^self]) asSound play.! !

!AudioChatGUI class methodsFor: 'as yet unclassified' stamp: 'RAA 8/4/2000 13:14'!
playOnArrival

	^PlayOnArrival ifNil: [PlayOnArrival _ false]! !


!AudioChatGUI class methodsFor: 'class initialization' stamp: 'RAA 8/5/2000 19:22'!
initialize

	EToyIncomingMessage
		forType: EToyIncomingMessage typeAudioChat 
		send: #handleNewAudioChatFrom:sentBy:ipAddress: 
		to: self.

	EToyIncomingMessage
		forType: EToyIncomingMessage typeAudioChatContinuous
		send: #handleNewAudioChat2From:sentBy:ipAddress: 
		to: self.


! !


!AudioChatGUI class methodsFor: 'creation' stamp: 'RAA 8/4/2000 14:06'!
openAsMorph

	AudioChatGUI new openInWorld.	"old syswindow version in #start"

! !


!AudioChatGUI class methodsFor: 'parts bin' stamp: 'sw 7/29/2007 01:57'!
descriptionForPartsBin
	"Answer a description of the receiver for use in a parts bin"

	^ self partName: 	'Audio chat' translatedNoop
		categories:		#()
		documentation:	'A tool for talking to other Squeak users' translatedNoop
		sampleImageForm: (Form
	extent: 110@70
	depth: 8
	fromArray: #( 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193845248 4193909241 4193845505 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 33159673 4193845248 4193909241 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843257 4193845248 4193908993 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 4193845248 4193845505 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 33095680 4193845505 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789619457 33095680 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789642629 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466465 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 2239817189 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857048960 2246173153 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850756577 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789653477 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857024481 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789642725 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857013729 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3783321061 3842048257 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857048960 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3783648741 31843813 31843813 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3842106853 3857048965 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3783321061 31843813 3857048833 16901605 3842106625 31843813 3842106625 31843813 3842048257 3857049061 16901605 16843237 3857048960 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3783648741 31843813 3856990693 3856990693 16843237 3842106853 16843237 3842106853 31843813 31843585 3856990693 3842106853 3857048965 3789619457 16842752 4177592577 31580641 3777505320 673720360 673720360 685891880 673720360 673720360 673720545 3777505320 673720360 673720360 685892065 3783321061 31843813 3856990693 3856990693 3842106853 3842106853 3842106853 3842106853 16843009 31785445 3857049061 3842106853 3857048960 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3783648741 31843813 3856990693 3856990693 3842106853 3842106853 3842106853 3842106853 31843813 3856990693 3857049061 3842106853 3857048965 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3783321061 31843813 31785445 3856990693 3842106853 3842106853 3842106853 3842106853 31843813 31843585 3856990693 3842106853 3857048960 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3783648741 3842048257 3857048833 16901605 16843237 16843237 16843237 16843237 3842048257 3857049061 16901605 3856990693 3857048965 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3783321061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857048960 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789642725 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857013729 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789653477 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857024481 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789676933 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850756577 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789677025 2239817189 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857048960 2246173153 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789677025 3789642629 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466465 3789677025 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789677025 3789677025 3789677025 3789676928 2239792512 2239792512 2239792512 2239792512 2239792512 2239816161 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3777505320 673720360 673720360 685891880 673720360 673720360 673720545 3777505320 673720360 673720360 685892065 3789677025 3789677025 3789677025 3783613413 3857049061 3857049061 3857049061 3857049061 3857049061 3857013637 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 2246436325 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 2246173153 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 16843009 16843009 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789642725 3842048257 16901605 16901605 3857049061 3857049061 3857049061 3857049061 3857013729 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789619457 16843009 16843009 16843233 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789653477 3856990693 3856990693 3842106853 3857049061 3857049061 3857049061 3857049061 3857024481 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 16843009 1888776340 1888776340 1879113985 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789642725 3856990693 3856990693 3842106853 3842048257 3857048833 16901377 16901605 3857013729 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789676801 16880752 2490406000 2490406000 2490405889 16900577 3789677025 3789677025 3789677025 3789677025 3789677025 3789653477 3856990693 3856990693 3842106853 31843813 31843813 31843813 31843813 3857024481 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789619457 26505364 1888776340 1888776340 1888776340 16843233 3789677025 3789677025 3789677025 3789677025 3789677025 3789642725 3856990465 16901605 3842106853 3842048257 31843813 3842106625 3857049061 3857013729 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789619457 2490406000 2490406000 2490406000 2490406000 2483093985 3789677025 3789677025 3789677025 3789677025 3789677025 3789653477 3856990693 3857049061 3842106853 31843813 31843813 3842106625 3857049061 3857024481 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3774939540 1888776340 1888776340 1888776340 1888776340 1888747777 3789677025 3789677025 3789677025 3789677025 3789677025 3789642725 3856990693 3857049061 3842106853 31843813 31843813 3856990693 3857049061 3857013729 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3774939504 2490406000 2490406000 2490406000 2490406000 2490368257 3789677025 3789677025 3789677025 3789677025 3789677025 3789653477 3842048257 3857049061 16843237 3842048257 3842106853 3856990693 3857049061 3857024481 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3774939393 3789677025 16871572 1888776340 1895825407 1888776340 1888776340 1888776193 31580641 3789677025 3789677025 3789677025 3789677025 3789642725 3857049061 3857049061 3857049061 3857049061 3857049061 3842106853 3857049061 3857013729 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16880752 2490406000 4285568112 4285568112 2490406000 2490405889 31580641 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 3857049061 3857049061 3857049061 3857049061 3842106853 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16871572 1888776340 4287918228 4287918228 1888776340 1888776193 31580641 3789677025 3789677025 3789677025 3789677025 3789676933 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16880752 2490406000 4285568112 4285568112 2490406000 2490405889 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 2246436325 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 2246173153 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16871572 1888776340 4287918228 4287918228 1888776340 1888776193 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3783613413 3857049061 3857049061 3857049061 3857049061 3857049061 3857013637 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16880752 2490406000 4285568112 4285568112 2490406000 2490405889 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 2239792512 2239792512 2239792512 2239792512 2239792512 2239816161 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16871572 1888776340 4287918228 4287918228 1888776340 1888776193 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 1535466373 1535466373 1535466373 1535466373 1535466373 1541530081 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3774939393 3789677025 16880752 2490406000 2499805183 2490406000 2490406000 2490405889 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789653376 3857049061 3857049061 3857049061 3857049061 3857049061 3850405345 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 16871572 1888776340 1888776340 1888776340 1888776340 1888776193 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3783648741 3857049061 3857049061 3857049061 3857049061 3857049061 3857048965 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3774939504 2490406000 2490406000 2490406000 2490406000 2490368257 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 2246436325 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 2246173153 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3774939540 1888776340 1888776340 1888776340 1888776340 1888747777 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 1541793253 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 1541530081 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789619457 2490406000 2490406000 2490406000 2490406000 2483093985 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3856990465 16843237 3857049061 3857048833 31843813 31843813 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789619457 26505364 1888776340 1888776340 1888776340 16843233 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3856990693 31785445 3857049061 3857049061 31843585 31843813 3857049061 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789676801 16880752 2490406000 2490406000 2490405889 16900577 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 31843813 3842048257 3857049061 31843813 31843585 31843813 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 16843009 1888776340 1888776340 1879113985 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3857049061 31843813 31843813 31843813 31843813 31785445 3857049061 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789619457 16843009 16843009 16843233 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 31843813 3842048257 31843813 31843813 16901605 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 16843009 16843009 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3857049061 31843813 31843813 31843813 31843813 31785445 3857049061 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 31843813 31843813 31843813 31843813 31843585 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3857048833 16901605 3842048257 3842106625 16901377 16901377 31843813 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 1541793253 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 1541530081 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 2246436325 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 2246173153 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3783648741 3857049061 3857049061 3857049061 3857049061 3857049061 3857048965 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789653376 3857049061 3857049061 3857049061 3857049061 3857049061 3850405345 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 1535466373 1535466373 1535466373 1535466373 1535466373 1541530081 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789619457 16842752 4193845505 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789619457 33095680 4193845505 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 33095680 4193908993 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 4193845248 4193909241 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843257 4193845248 4193909241 4193845505 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 33159673 4193845248)
	offset: 0@0)! !
Object subclass: #Authorizer
	instanceVariableNames: 'users realm'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Url'!
!Authorizer commentStamp: '<historical>' prior: 0!
The Authorizer does user authorization checking. Each instance of authorizer keeps track of the realm that it is authorizing for, and the table of authorized users. An authorizer can be asked to return the user name/symbol associated with a userID (which concatenates the username and password from the HTTP request) with the user: method.
!


!Authorizer methodsFor: 'realms' stamp: 'mjg 11/3/97 12:33'!
realm
	^realm! !

!Authorizer methodsFor: 'realms' stamp: 'mjg 11/3/97 12:33'!
realm: aString
	realm := aString
! !


!Authorizer methodsFor: 'authentication' stamp: 'mjg 11/3/97 13:01'!
encode: nameString password: pwdString
	"Encode per RFC1421 of the username:password combination."

	| clear code clearSize idx map |
	clear := (nameString, ':', pwdString) asByteArray.
	clearSize := clear size.
	[ clear size \\ 3 ~= 0 ] whileTrue: [ clear := clear, #(0) ].
	idx := 1.
	map := 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'.
	code := WriteStream on: ''.
	[ idx < clear size ] whileTrue: [ code 
		nextPut: (map at: (clear at: idx) // 4 + 1);
		nextPut: (map at: (clear at: idx) \\ 4 * 16 + ((clear at: idx + 1) // 16) + 1);
   		nextPut: (map at: (clear at: idx + 1) \\ 16 * 4 + ((clear at: idx + 2) // 64) + 1);
   		nextPut: (map at: (clear at: idx + 2) \\ 64 + 1).
		idx := idx + 3 ].
	code := code contents.
	idx := code size.
	clear size - clearSize timesRepeat: [ code at: idx put: $=. idx := idx - 1].
	^code! !

!Authorizer methodsFor: 'authentication' stamp: 'mjg 11/3/97 12:31'!
mapFrom: aKey to: aPerson
	"Establish a mapping from a RFC 1421 key to a user."

	users isNil ifTrue: [ users := Dictionary new ].
	aPerson
	 isNil ifTrue: [ users removeKey: aKey ]
	 ifFalse: [
		users removeKey: (users keyAtValue: aPerson ifAbsent: []) ifAbsent: [].
		users at: aKey put: aPerson ]
! !

!Authorizer methodsFor: 'authentication' stamp: 'tk 5/21/1998 16:32'!
mapName: nameString password: pwdString to: aPerson
	"Insert/remove the encoding per RFC1421 of the username:password combination into/from the UserMap.  DO NOT call this directly, use mapName:password:to: in your ServerAction class.  Only it knows how to record the change on the disk!!"

	self mapFrom: (self encode: nameString password: pwdString) to: aPerson
! !

!Authorizer methodsFor: 'authentication' stamp: 'ar 8/17/2001 18:19'!
user: userId
	"Return the requesting user."
	^users at: userId ifAbsent: [ self error: (self class unauthorizedFor: realm) ]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Authorizer class
	instanceVariableNames: ''!

!Authorizer class methodsFor: 'as yet unclassified' stamp: 'ar 8/17/2001 18:19'!
unauthorizedFor: realm
	^'HTTP/1.0 401 Unauthorized', self crlf, 'WWW-Authenticate: Basic realm="Squeak/',realm,'"',
	String crlfcrlf, '<html><title>Unauthorized</title><body><h2>Unauthorized for ',realm, '</h2></body></html>'

! !
Object subclass: #AutoStart
	instanceVariableNames: 'parameters'
	classVariableNames: 'Active InstalledLaunchers'
	poolDictionaries: ''
	category: 'System-Support'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AutoStart class
	instanceVariableNames: ''!

!AutoStart class methodsFor: 'class initialization' stamp: 'mir 7/28/1999 17:44'!
deinstall
	"AutoStart deinstall"

	Smalltalk removeFromStartUpList: AutoStart.
	InstalledLaunchers _ nil! !

!AutoStart class methodsFor: 'class initialization' stamp: 'mir 9/30/2004 15:05'!
initialize
	"AutoStart initialize"
	"Order: ExternalSettings, SecurityManager, AutoStart"
	Smalltalk addToStartUpList: AutoStart after: SecurityManager.
	Smalltalk addToShutDownList: AutoStart after: SecurityManager.! !

!AutoStart class methodsFor: 'class initialization' stamp: 'mir 9/30/2004 15:06'!
shutDown: quitting
	self active: false! !

!AutoStart class methodsFor: 'class initialization' stamp: 'bf 11/23/2004 19:01'!
startUp: resuming
	"The image is either being newly started (resuming is true), or it's just been snapshotted.
	If this has just been a snapshot, skip all the startup stuff."

	| startupParameters launchers |
	self active ifTrue: [^self].
	self active: true.
	resuming ifFalse: [^self].

	HTTPClient determineIfRunningInBrowser.
	startupParameters _ AbstractLauncher extractParameters.
	(startupParameters includesKey: 'apiSupported' asUppercase )
		ifTrue: [
			HTTPClient browserSupportsAPI: ((startupParameters at: 'apiSupported' asUppercase) asUppercase = 'TRUE').
			HTTPClient isRunningInBrowser
				ifFalse: [HTTPClient isRunningInBrowser: true]].
	self checkForUpdates
		ifTrue: [^self].
	self checkForPluginUpdate.
	launchers _ self installedLaunchers collect: [:launcher |
		launcher new].
	launchers do: [:launcher |
		launcher parameters: startupParameters].
	launchers do: [:launcher |
		Smalltalk at: #WorldState ifPresent: [ :ws | ws addDeferredUIMessage: [launcher startUp] fixTemps]]! !


!AutoStart class methodsFor: 'accessing' stamp: 'mir 7/28/1999 17:47'!
addLauncher: launcher
	self installedLaunchers add: launcher! !

!AutoStart class methodsFor: 'accessing'!
addLauncherFirst: launcher
	self installedLaunchers addFirst: launcher! !

!AutoStart class methodsFor: 'accessing' stamp: 'mir 7/28/1999 17:47'!
removeLauncher: launcher
	self installedLaunchers remove: launcher ifAbsent: []! !


!AutoStart class methodsFor: 'private' stamp: 'mir 9/7/2004 13:34'!
active
	^ Active == true! !

!AutoStart class methodsFor: 'private' stamp: 'mir 9/7/2004 13:36'!
active: aBoolean
	Active := aBoolean! !

!AutoStart class methodsFor: 'private' stamp: 'mir 7/28/1999 17:43'!
installedLaunchers
	InstalledLaunchers ifNil: [
		InstalledLaunchers _ OrderedCollection new].
	^InstalledLaunchers! !


!AutoStart class methodsFor: 'updating' stamp: 'mir 3/5/2004 20:43'!
checkForPluginUpdate
	| pluginVersion updateURL |
	World 
		ifNotNil: [
			World install.
			ActiveHand position: 100@100].
	HTTPClient isRunningInBrowser
		ifFalse: [^false].
	pluginVersion _ AbstractLauncher extractParameters
		at: (SmalltalkImage current platformName copyWithout: Character space) asUppercase
		ifAbsent: [^false].
	updateURL _ AbstractLauncher extractParameters
		at: 'UPDATE_URL'
		ifAbsent: [^false].
	^SystemVersion check: pluginVersion andRequestPluginUpdate: updateURL! !

!AutoStart class methodsFor: 'updating' stamp: 'mir 11/13/2003 19:09'!
checkForUpdates
	| availableUpdate updateServer |
	World 
		ifNotNil: [
			World install.
			ActiveHand position: 100@100].
	HTTPClient isRunningInBrowser
		ifFalse: [^self processUpdates].
	availableUpdate _ (AbstractLauncher extractParameters
		at: 'UPDATE'
		ifAbsent: [''] ) asInteger.
	availableUpdate
		ifNil: [^false].
	updateServer _ AbstractLauncher extractParameters
		at: 'UPDATESERVER'
		ifAbsent: [AbstractLauncher extractParameters
		at: 'UPDATE_SERVER'
		ifAbsent: ['Squeakland']].
	Utilities setUpdateServer: updateServer.
	^SystemVersion checkAndApplyUpdates: availableUpdate! !

!AutoStart class methodsFor: 'updating' stamp: 'mir 3/4/2005 10:52'!
processUpdates
	"Process update files from a well-known update server.  This method is called at system startup time,   Only if the preference #updateFromServerAtStartup is true is the actual update processing undertaken automatically"

	(Preferences valueOfFlag: #updateFromServerAtStartup)
		ifTrue: [
			| choice |
			choice _ (PopUpMenu labels: 'Yes, Update\No, Not now\Don''t ask again' withCRs)
				startUpWithCaption: 'Do you want to check for updates\or maintenance fixes on the server?' withCRs.
			choice = 1 ifTrue: [Utilities updateFromServer].
			choice = 3 ifTrue: [
				Preferences setPreference: #updateFromServerAtStartup toValue: false.
				self inform: 'Remember to save you image to make this setting permant.'].
		].
	^false! !
Morph subclass: #BackgroundMorph
	instanceVariableNames: 'image offset delta running'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!BackgroundMorph commentStamp: '<historical>' prior: 0!
This morph incorporates tiling and regular motion with the intent of supporting, eg, panning of endless (toroidal) backgrounds.

The idea is that embedded morphs get displayed at a moving offset relative to my position.  Moreover this display is tiled according to the bounding box of the submorphs (subBounds), as much as necesary to fill the rest of my bounds.!


!BackgroundMorph methodsFor: 'accessing' stamp: 'fc 7/24/2004 12:23'!
delta
	^delta! !

!BackgroundMorph methodsFor: 'accessing' stamp: 'fc 7/24/2004 12:24'!
delta: aPoint

	delta _ aPoint.! !

!BackgroundMorph methodsFor: 'accessing' stamp: 'fc 7/24/2004 13:50'!
offset
	^offset! !

!BackgroundMorph methodsFor: 'accessing' stamp: 'fc 7/24/2004 13:50'!
offset: aPoint
	offset _ aPoint! !

!BackgroundMorph methodsFor: 'accessing'!
slideBy: inc
	submorphs isEmpty ifTrue: [^ self].
	offset _ offset + inc \\ self subBounds extent.
	self changed! !

!BackgroundMorph methodsFor: 'accessing'!
startRunning
	running _ true.
	self changed! !

!BackgroundMorph methodsFor: 'accessing'!
stopRunning
	running _ false.
	self changed! !

!BackgroundMorph methodsFor: 'accessing' stamp: 'aoy 2/17/2003 01:20'!
subBounds
	"calculate the submorph bounds"

	| subBounds |
	subBounds := nil.
	self submorphsDo: 
			[:m | 
			subBounds := subBounds isNil
						ifTrue: [m fullBounds]
						ifFalse: [subBounds merge: m fullBounds]].
	^subBounds! !


!BackgroundMorph methodsFor: 'drawing' stamp: 'ar 6/17/1999 01:06'!
drawOn: aCanvas
	"The tiling is solely determined by bounds, subBounds and offset.
	The extent of display is determined by bounds and the clipRect of the canvas."
	| start d subBnds |
	submorphs isEmpty ifTrue: [^ super drawOn: aCanvas].
	subBnds _ self subBounds.
	running ifFalse:
		[super drawOn: aCanvas.
		^ aCanvas fillRectangle: subBnds color: Color lightBlue].
	start _ subBnds topLeft + offset - bounds topLeft - (1@1) \\ subBnds extent - subBnds extent + (1@1).
	d _ subBnds topLeft - bounds topLeft.
"Sensor redButtonPressed ifTrue: [self halt]."
	start x to: bounds width - 1 by: subBnds width do:
		[:x |
		start y to: bounds height - 1 by: subBnds height do:
			[:y | aCanvas translateBy: (x@y) - d clippingTo: bounds
				during:[:tileCanvas| self drawSubmorphsOn: tileCanvas]]].! !

!BackgroundMorph methodsFor: 'drawing' stamp: 'ar 12/30/2001 19:16'!
fullDrawOn: aCanvas
	(aCanvas isVisible: self fullBounds) ifFalse:[^self].
	running ifFalse: [
		^aCanvas clipBy: (bounds translateBy: aCanvas origin)
				during:[:clippedCanvas| super fullDrawOn: clippedCanvas]].
	(aCanvas isVisible: self bounds) ifTrue:[aCanvas drawMorph: self].
! !


!BackgroundMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:43'!
initialize
	"initialize the state of the receiver"
	super initialize.
""
	offset _ 0 @ 0.
	delta _ 1 @ 0.
	running _ true! !


!BackgroundMorph methodsFor: 'layout'!
fullBounds
	^ self bounds! !

!BackgroundMorph methodsFor: 'layout'!
layoutChanged
	"Do nothing, since I clip my submorphs"! !


!BackgroundMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:56'!
addCustomMenuItems: aCustomMenu hand: aHandMorph 
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	running
		ifTrue: [aCustomMenu add: 'stop' translated action: #stopRunning]
		ifFalse: [aCustomMenu add: 'start' translated action: #startRunning]! !


!BackgroundMorph methodsFor: 'stepping and presenter' stamp: 'fc 7/24/2004 13:47'!
step
	
	running ifTrue: [self slideBy: delta]! !


!BackgroundMorph methodsFor: 'testing'!
stepTime
	"Answer the desired time between steps in milliseconds."

	^ 20! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BackgroundMorph class
	instanceVariableNames: ''!

!BackgroundMorph class methodsFor: 'as yet unclassified' stamp: 'kfr 8/7/2004 16:10'!
test
	"BackgroundMorph test"
	^(BackgroundMorph new addMorph: (ImageMorph new image: Form fromUser))openInWorld.! !
Object subclass: #BadEqualer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-Utilities'!
!BadEqualer commentStamp: 'mjr 8/20/2003 13:28' prior: 0!
I am an object that doesn't always report #= correctly.  Used for testing the EqualityTester.!


!BadEqualer methodsFor: 'comparing' stamp: 'mjr 8/20/2003 18:56'!
= other 
	self class = other class
		ifFalse: [^ false].
	^ 100 atRandom < 30 ! !
Object subclass: #BadHasher
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-Utilities'!
!BadHasher commentStamp: 'mjr 8/20/2003 13:28' prior: 0!
I am an object that doesn't always hash correctly.  I am used for testing the HashTester.!


!BadHasher methodsFor: 'comparing' stamp: 'mjr 8/20/2003 18:56'!
hash
	"answer with a different hash some of the time"
	100 atRandom < 30
		ifTrue: [^ 1]. 
	^ 2! !
Collection subclass: #Bag
	instanceVariableNames: 'contents'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Unordered'!
!Bag commentStamp: '<historical>' prior: 0!
I represent an unordered collection of possibly duplicate elements.
	
I store these elements in a dictionary, tallying up occurrences of equal objects. Because I store an occurrence only once, my clients should beware that objects they store will not necessarily be retrieved such that == is true. If the client cares, a subclass of me should be created.!


!Bag methodsFor: 'accessing' stamp: 'sma 5/12/2000 17:23'!
at: index 
	self errorNotKeyed! !

!Bag methodsFor: 'accessing' stamp: 'sma 5/12/2000 17:23'!
at: index put: anObject 
	self errorNotKeyed! !

!Bag methodsFor: 'accessing' stamp: 'tao 1/5/2000 18:25'!
cumulativeCounts
	"Answer with a collection of cumulative percents covered by elements so far."
	| s n |
	s _ self size / 100.0. n _ 0.
	^ self sortedCounts asArray collect:
		[:a | n _ n + a key. (n / s roundTo: 0.1) -> a value]! !

!Bag methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:35'!
size
	"Answer how many elements the receiver contains."

	| tally |
	tally _ 0.
	contents do: [:each | tally _ tally + each].
	^ tally! !

!Bag methodsFor: 'accessing' stamp: 'sma 6/15/2000 17:00'!
sortedCounts
	"Answer with a collection of counts with elements, sorted by decreasing
	count."

	| counts |
	counts _ SortedCollection sortBlock: [:x :y | x >= y].
	contents associationsDo:
		[:assn |
		counts add: (Association key: assn value value: assn key)].
	^ counts! !

!Bag methodsFor: 'accessing'!
sortedElements
	"Answer with a collection of elements with counts, sorted by element."

	| elements |
	elements _ SortedCollection new.
	contents associationsDo: [:assn | elements add: assn].
	^elements! !


!Bag methodsFor: 'adding' stamp: 'sma 5/12/2000 17:18'!
add: newObject 
	"Include newObject as one of the receiver's elements. Answer newObject."

	^ self add: newObject withOccurrences: 1! !

!Bag methodsFor: 'adding' stamp: 'sma 5/12/2000 17:20'!
add: newObject withOccurrences: anInteger 
	"Add newObject anInteger times to the receiver. Answer newObject."

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


!Bag methodsFor: 'converting' stamp: 'sma 5/12/2000 14:34'!
asBag
	^ self! !

!Bag methodsFor: 'converting' stamp: 'sma 5/12/2000 14:30'!
asSet
	"Answer a set with the elements of the receiver."

	^ contents keys! !


!Bag methodsFor: 'copying' stamp: 'sma 5/12/2000 14:53'!
copy
	^ self shallowCopy setContents: contents copy! !


!Bag methodsFor: 'enumerating'!
do: aBlock 
	"Refer to the comment in Collection|do:."

	contents associationsDo: [:assoc | assoc value timesRepeat: [aBlock value: assoc key]]! !


!Bag methodsFor: 'private' stamp: 'sma 5/12/2000 14:49'!
setContents: aDictionary
	contents _ aDictionary! !


!Bag methodsFor: 'removing' stamp: 'sma 5/12/2000 14:32'!
remove: oldObject ifAbsent: exceptionBlock 
	"Refer to the comment in Collection|remove:ifAbsent:."

	| count |
	count _ contents at: oldObject ifAbsent: [^ exceptionBlock value].
	count = 1
		ifTrue: [contents removeKey: oldObject]
		ifFalse: [contents at: oldObject put: count - 1].
	^ oldObject! !


!Bag methodsFor: 'testing'!
includes: anObject 
	"Refer to the comment in Collection|includes:."

	^contents includesKey: anObject! !

!Bag methodsFor: 'testing'!
occurrencesOf: anObject 
	"Refer to the comment in Collection|occurrencesOf:."

	(self includes: anObject)
		ifTrue: [^contents at: anObject]
		ifFalse: [^0]! !


!Bag methodsFor: 'comparing' stamp: 'md 10/17/2004 16:09'!
= aBag
	"Two bags are equal if
	 (a) they are the same 'kind' of thing.
	 (b) they have the same size.
	 (c) each element occurs the same number of times in both of them"

	(aBag isKindOf: Bag) ifFalse: [^false].
	self size = aBag size ifFalse: [^false].
	contents associationsDo: [:assoc|
		(aBag occurrencesOf: assoc key) = assoc value
			ifFalse: [^false]].
	^true

! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Bag class
	instanceVariableNames: ''!

!Bag class methodsFor: 'instance creation' stamp: 'nk 3/17/2001 09:52'!
contentsClass
	^Dictionary! !

!Bag class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 13:31'!
new
	^ self new: 4! !

!Bag class methodsFor: 'instance creation' stamp: 'nk 3/17/2001 09:52'!
new: nElements
	^ super new setContents: (self contentsClass new: nElements)! !

!Bag class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 17:17'!
newFrom: aCollection 
	"Answer an instance of me containing the same elements as aCollection."

	^ self withAll: aCollection

"Examples:
	Bag newFrom: {1. 2. 3. 3}
	{1. 2. 3. 3} as: Bag
"! !
Object subclass: #BalloonBezierSimulation
	instanceVariableNames: 'start end via lastX lastY fwDx fwDy fwDDx fwDDy maxSteps'
	classVariableNames: 'HeightSubdivisions LineConversions MonotonSubdivisions OverflowSubdivisions'
	poolDictionaries: ''
	category: 'Balloon-Simulation'!
!BalloonBezierSimulation commentStamp: '<historical>' prior: 0!
This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.!


!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'!
end
	^end! !

!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'!
end: aPoint
	end _ aPoint! !

!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 01:57'!
inTangent
	"Return the tangent at the start point"
	^via - start! !

!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'!
initialX
	^start y <= end y
		ifTrue:[start x]
		ifFalse:[end x]! !

!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'!
initialY
	^start y <= end y
		ifTrue:[start y]
		ifFalse:[end y]! !

!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'!
initialZ
	^0 "Assume no depth given"! !

!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 01:57'!
outTangent
	"Return the tangent at the end point"
	^end - via! !

!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'!
start
	^start! !

!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'!
start: aPoint
	start _ aPoint! !

!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'!
via
	^via! !

!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'!
via: aPoint
	via _ aPoint! !


!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 20:46'!
computeInitialStateFrom: source with: transformation
	"Compute the initial state in the receiver."
	start _ (transformation localPointToGlobal: source start) asIntegerPoint.
	end _ (transformation localPointToGlobal: source end) asIntegerPoint.
	via _ (transformation localPointToGlobal: source via) asIntegerPoint.! !

!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 02:39'!
computeSplitAt: t
	"Split the receiver at the parametric value t"
	| left right newVia1 newVia2 newPoint |
	left _ self clone.
	right _ self clone.
	"Compute new intermediate points"
	newVia1 _ (via - start) * t + start.
	newVia2 _ (end - via) * t + via.
	"Compute new point on curve"
	newPoint _ ((newVia1 - newVia2) * t + newVia2) asIntegerPoint.
	left via: newVia1 asIntegerPoint.
	left end: newPoint.
	right start: newPoint.
	right via: newVia2 asIntegerPoint.
	^Array with: left with: right! !

!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 01:34'!
floatStepToFirstScanLineAt: yValue in: edgeTableEntry
	"Float version of forward differencing"
	|  startX endX startY endY deltaY fwX1 fwX2 fwY1 fwY2 
	steps scaledStepSize squaredStepSize |
	(end y) >= (start y) ifTrue:[
		startX _ start x.	endX _ end x.
		startY _ start y.	endY _ end y.
	] ifFalse:[
		startX _ end x.	endX _ start x.
		startY _ end y.	endY _ start y.
	].

	deltaY _ endY - startY.

	"Quickly check if the line is visible at all"
	(yValue >= endY or:[deltaY = 0]) ifTrue:[
		^edgeTableEntry lines: 0].

	fwX1 _ (startX + endX - (2 * via x)) asFloat.
	fwX2 _ (via x - startX * 2) asFloat.
	fwY1 _ (startY + endY - (2 * via y)) asFloat.
	fwY2 _ ((via y - startY) * 2) asFloat.
	steps _ deltaY asInteger * 2.
	scaledStepSize _ 1.0 / steps asFloat.
	squaredStepSize _ scaledStepSize * scaledStepSize.
	fwDx _ fwX2 * scaledStepSize.
	fwDDx _ 2.0 * fwX1 * squaredStepSize.
	fwDy _ fwY2 * scaledStepSize.
	fwDDy _ 2.0 * fwY1 * squaredStepSize.
	fwDx _ fwDx + (fwDDx * 0.5).
	fwDy _ fwDy + (fwDDy * 0.5).

	lastX _ startX asFloat.
	lastY _ startY asFloat.

	"self xDirection: xDir.
	self yDirection: yDir."
	edgeTableEntry xValue: startX.
	edgeTableEntry yValue: startY.
	edgeTableEntry zValue: 0.
	edgeTableEntry lines: deltaY.

	"If not at first scan line then step down to yValue"
	yValue = startY ifFalse:[
		self stepToNextScanLineAt: yValue in: edgeTableEntry.
		"And adjust remainingLines"
		edgeTableEntry lines: deltaY - (yValue - startY).
	].! !

!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 02:45'!
floatStepToNextScanLineAt: yValue in: edgeTableEntry
	"Float version of forward differencing"
	[yValue asFloat > lastY] whileTrue:[
		(fwDx < -50.0 or:[fwDx > 50.0]) ifTrue:[self halt].
		(fwDy < -50.0 or:[fwDy > 50.0]) ifTrue:[self halt].
		(fwDDx < -50.0 or:[fwDDx > 50.0]) ifTrue:[self halt].
		(fwDDy < -50.0 or:[fwDDy > 50.0]) ifTrue:[self halt].
		lastX _ lastX + fwDx.
		lastY _ lastY + fwDy.
		fwDx _ fwDx + fwDDx.
		fwDy _ fwDy + fwDDy.
	].
	edgeTableEntry xValue: lastX asInteger.
	edgeTableEntry zValue: 0.! !

!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 16:23'!
intStepToFirstScanLineAt: yValue in: edgeTableEntry
	"Scaled integer version of forward differencing"
	|  startX endX startY endY deltaY fwX1 fwX2 fwY1 fwY2 
	 scaledStepSize squaredStepSize |
	(end y) >= (start y) ifTrue:[
		startX _ start x.	endX _ end x.
		startY _ start y.	endY _ end y.
	] ifFalse:[
		startX _ end x.	endX _ start x.
		startY _ end y.	endY _ start y.
	].

	deltaY _ endY - startY.

	"Quickly check if the line is visible at all"
	(yValue >= endY or:[deltaY = 0]) ifTrue:[
		^edgeTableEntry lines: 0].

	fwX1 _ (startX + endX - (2 * via x)).
	fwX2 _ (via x - startX * 2).
	fwY1 _ (startY + endY - (2 * via y)).
	fwY2 _ ((via y - startY) * 2).
	maxSteps _ deltaY asInteger * 2.
	scaledStepSize _ 16r1000000 // maxSteps.
	"@@: Okay, we need some fancy 64bit multiplication here"
	squaredStepSize _ self absoluteSquared8Dot24: scaledStepSize.
	squaredStepSize = ((scaledStepSize * scaledStepSize) bitShift: -24)
		ifFalse:[self error:'Bad computation'].
	fwDx _ fwX2 * scaledStepSize.
	fwDDx _ 2 * fwX1 * squaredStepSize.
	fwDy _ fwY2 * scaledStepSize.
	fwDDy _ 2 * fwY1 * squaredStepSize.
	fwDx _ fwDx + (fwDDx // 2).
	fwDy _ fwDy + (fwDDy // 2).

	self validateIntegerRange.

	lastX _ startX * 256.
	lastY _ startY * 256.

	edgeTableEntry xValue: startX.
	edgeTableEntry yValue: startY.
	edgeTableEntry zValue: 0.
	edgeTableEntry lines: deltaY.

	"If not at first scan line then step down to yValue"
	yValue = startY ifFalse:[
		self stepToNextScanLineAt: yValue in: edgeTableEntry.
		"And adjust remainingLines"
		edgeTableEntry lines: deltaY - (yValue - startY).
	].! !

!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 04:02'!
intStepToNextScanLineAt: yValue in: edgeTableEntry
	"Scaled integer version of forward differencing"
	[maxSteps >= 0 and:[yValue * 256 > lastY]] whileTrue:[
		self validateIntegerRange.
		lastX _ lastX + ((fwDx + 16r8000) // 16r10000).
		lastY _ lastY + ((fwDy + 16r8000) // 16r10000).
		fwDx _ fwDx + fwDDx.
		fwDy _ fwDy + fwDDy.
		maxSteps _ maxSteps - 1.
	].
	edgeTableEntry xValue: lastX // 256.
	edgeTableEntry zValue: 0.! !

!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/29/1998 22:14'!
isMonoton
	"Return true if the receiver is monoton along the y-axis,
	e.g., check if the tangents have the same sign"
	^(via y - start y) * (end y - via y) >= 0! !

!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/31/1998 16:36'!
stepToFirstScanLineAt: yValue in: edgeTableEntry
	"Compute the initial x value for the scan line at yValue"
	^self intStepToFirstScanLineAt: yValue in: edgeTableEntry! !

!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 03:40'!
stepToNextScanLineAt: yValue in: edgeTableEntry
	"Compute the next x value for the scan line at yValue.
	This message is sent during incremental updates. 
	The yValue parameter is passed in here for edges
	that have more complicated computations,"
	^self intStepToNextScanLineAt: yValue in: edgeTableEntry! !

!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 11/1/1998 00:31'!
subdivide
	"Subdivide the receiver"
	| dy dx |
	"Test 1: If the bezier curve is not monoton in Y, we need a subdivision"
	self isMonoton ifFalse:[
		MonotonSubdivisions _ MonotonSubdivisions + 1.
		^self subdivideToBeMonoton].

	"Test 2: If the receiver is horizontal, don't do anything"
	(end y = start y) ifTrue:[^nil].

	"Test 3: If the receiver can be represented as a straight line,
			make a line from the receiver and declare it invalid"
	((end - start) crossProduct: (via - start)) = 0 ifTrue:[
		LineConversions _ LineConversions + 1.
		^self subdivideToBeLine].

	"Test 4: If the height of the curve exceeds 256 pixels, subdivide 
			(forward differencing is numerically not very stable)"
	dy _ end y - start y.
	dy < 0 ifTrue:[dy _ dy negated].
	(dy > 255) ifTrue:[
		HeightSubdivisions _ HeightSubdivisions + 1.
		^self subdivideAt: 0.5].

	"Test 5: Check if the incremental values could possibly overflow the scaled integer range"
	dx _ end x - start x.
	dx < 0 ifTrue:[dx _ dx negated].
	dy * 32 < dx ifTrue:[
		OverflowSubdivisions _ OverflowSubdivisions + 1.
		^self subdivideAt: 0.5].

	^nil! !

!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 22:13'!
subdivideAt: parameter
	"Subdivide the receiver at the given parameter"
	| both |
	(parameter <= 0.0 or:[parameter >= 1.0]) ifTrue:[self halt].
	both _ self computeSplitAt: parameter.
	"Transcript cr.
	self quickPrint: self.
	Transcript space.
	self quickPrint: both first.
	Transcript space.
	self quickPrint: both last.
	Transcript endEntry."
	self via: both first via.
	self end: both first end.
	^both last! !

!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 11/11/1998 22:15'!
subdivideToBeLine
	"Not a true subdivision.
	Just return a line representing the receiver and fake me to be of zero height"
	| line |
	line _ BalloonLineSimulation new.
	line start: start.
	line end: end.
	"Make me invalid"
	end _ start.
	via _ start.
	 ^line! !

!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 02:24'!
subdivideToBeMonoton
	"Subdivide the receiver at it's extreme point"
	| v1 v2 t other |
	v1 _ (via - start).
	v2 _ (end - via).
	t _ (v1 y / (v2 y - v1 y)) negated asFloat.
	other _ self subdivideAt: t.
	self isMonoton ifFalse:[self halt].
	other isMonoton ifFalse:[self halt].
	^other! !


!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 16:37'!
absoluteSquared8Dot24: value
	"Compute the squared value of a 8.24 number with 0.0 <= value < 1.0,
	e.g., compute (value * value) bitShift: -24"
	| halfWord1 halfWord2 result |
	(value >= 0 and:[value < 16r1000000]) ifFalse:[^self error:'Value out of range'].
	halfWord1 _ value bitAnd: 16rFFFF.
	halfWord2 _ (value bitShift: -16) bitAnd: 255.

	result _ (halfWord1 * halfWord1) bitShift: -16. "We don't need the lower 16bits at all"
	result _ result + ((halfWord1 * halfWord2) * 2).
	result _ result + ((halfWord2 * halfWord2) bitShift: 16).
	"word1 _ halfWord1 * halfWord1.
	word2 _ (halfWord2 * halfWord1) + (word1 bitShift: -16).
	word1 _ word1 bitAnd: 16rFFFF.
	word2 _ word2 + (halfWord1 * halfWord2).
	word2 _ word2 + ((halfWord2 * halfWord2) bitShift: 16)."

	^result bitShift: -8! !

!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 5/25/2000 17:57'!
debugDraw
	| entry minY maxY lX lY canvas |
	entry _ BalloonEdgeData new.
	canvas _ Display getCanvas.
	minY _ (start y min: end y) min: via y.
	maxY _ (start y max: end y) max: via y.
	entry yValue: minY.
	self stepToFirstScanLineAt: minY in: entry.
	lX _ entry xValue.
	lY _ entry yValue.
	minY+1 to: maxY do:[:y|
		self stepToNextScanLineAt: y in: entry.
		canvas line: lX@lY to: entry xValue @ y width: 2 color: Color black.
		lX _ entry xValue.
		lY _ y.
	].
! !

!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 5/25/2000 17:57'!
debugDraw2
	| canvas last max t next |
	canvas _ Display getCanvas.
	max _ 100.
	last _ nil.
	0 to: max do:[:i|
		t _ i asFloat / max asFloat.
		next _ self valueAt: t.
		last ifNotNil:[
			canvas line: last to: next rounded width: 2 color: Color blue.
		].
		last _ next rounded.
	].! !

!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 5/25/2000 17:57'!
debugDrawWide: n
	| entry minY maxY canvas curve p1 p2 entry2 y |
	curve _ self class new.
	curve start: start + (0@n).
	curve via: via + (0@n).
	curve end: end + (0@n).
	entry _ BalloonEdgeData new.
	entry2 _ BalloonEdgeData new.
	canvas _ Display getCanvas.
	minY _ (start y min: end y) min: via y.
	maxY _ (start y max: end y) max: via y.
	entry yValue: minY.
	entry2 yValue: minY + n.
	self stepToFirstScanLineAt: minY in: entry.
	curve stepToFirstScanLineAt: minY+n in: entry2.
	y _ minY.
	1 to: n do:[:i|
		y _ y + 1.
		self stepToNextScanLineAt: y in: entry.
		p1 _ entry xValue @ y.
		canvas line: p1 to: p1 + (n@0) width: 1 color: Color black.
	].
	[y < maxY] whileTrue:[
		y _ y + 1.
		self stepToNextScanLineAt: y in: entry.
		p2 _ (entry xValue + n) @ y.
		curve stepToNextScanLineAt: y in: entry2.
		p1 _ entry2 xValue @ y.
		canvas line: p1 to: p2 width: 1 color: Color black.
	].
! !

!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 00:35'!
printOn: aStream
	aStream 
		nextPutAll: self class name;
		nextPut:$(;
		print: start;
		nextPutAll:' - ';
		print: via;
		nextPutAll:' - ';
		print: end;
		nextPut:$)! !

!BalloonBezierSimulation methodsFor: 'private' stamp: 'MPW 1/1/1901 21:55'!
printOnStream: aStream
	aStream 
		print: self class name;
		print:'(';
		write: start;
		print:' - ';
		write: via;
		print:' - ';
		write: end;
		print:')'.! !

!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 21:56'!
quickPrint: curve
	Transcript nextPut:$(;
		print: curve start;
		space;
		print: curve via;
		space;
		print: curve end;
		nextPut:$).! !

!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 22:13'!
quickPrint: curve first: aBool
	aBool ifTrue:[Transcript cr].
	Transcript nextPut:$(;
		print: curve start;
		space;
		print: curve via;
		space;
		print: curve end;
		nextPut:$).
	Transcript endEntry.! !

!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 03:53'!
stepToFirst
	|  startX endX startY endY deltaY fwX1 fwX2 fwY1 fwY2 
	steps scaledStepSize squaredStepSize |
	(end y) >= (start y) ifTrue:[
		startX _ start x.	endX _ end x.
		startY _ start y.	endY _ end y.
	] ifFalse:[
		startX _ end x.	endX _ start x.
		startY _ end y.	endY _ start y.
	].

	deltaY _ endY - startY.

	"Quickly check if the line is visible at all"
	(deltaY = 0) ifTrue:[^self].

	fwX1 _ (startX + endX - (2 * via x)) asFloat.
	fwX2 _ (via x - startX * 2) asFloat.
	fwY1 _ (startY + endY - (2 * via y)) asFloat.
	fwY2 _ ((via y - startY) * 2) asFloat.
	steps _ deltaY asInteger * 2.
	scaledStepSize _ 1.0 / steps asFloat.
	squaredStepSize _ scaledStepSize * scaledStepSize.
	fwDx _ fwX2 * scaledStepSize.
	fwDDx _ 2.0 * fwX1 * squaredStepSize.
	fwDy _ fwY2 * scaledStepSize.
	fwDDy _ 2.0 * fwY1 * squaredStepSize.
	fwDx _ fwDx + (fwDDx * 0.5).
	fwDy _ fwDy + (fwDDy * 0.5).

	lastX _ startX asFloat.
	lastY _ startY asFloat.
! !

!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 03:50'!
stepToFirstInt
	"Scaled integer version of forward differencing"
	|  startX endX startY endY deltaY fwX1 fwX2 fwY1 fwY2 
	 scaledStepSize squaredStepSize |
	self halt.
	(end y) >= (start y) ifTrue:[
		startX _ start x.	endX _ end x.
		startY _ start y.	endY _ end y.
	] ifFalse:[
		startX _ end x.	endX _ start x.
		startY _ end y.	endY _ start y.
	].

	deltaY _ endY - startY.

	"Quickly check if the line is visible at all"
	(deltaY = 0) ifTrue:[^nil].

	fwX1 _ (startX + endX - (2 * via x)).
	fwX2 _ (via x - startX * 2).
	fwY1 _ (startY + endY - (2 * via y)).
	fwY2 _ ((via y - startY) * 2).
	maxSteps _ deltaY asInteger * 2.
	scaledStepSize _ 16r1000000 // maxSteps.
	"@@: Okay, we need some fancy 64bit multiplication here"
	squaredStepSize _ (scaledStepSize * scaledStepSize) bitShift: -24.
	fwDx _ fwX2 * scaledStepSize.
	fwDDx _ 2 * fwX1 * squaredStepSize.
	fwDy _ fwY2 * scaledStepSize.
	fwDDy _ 2 * fwY1 * squaredStepSize.
	fwDx _ fwDx + (fwDDx // 2).
	fwDy _ fwDy + (fwDDy // 2).

	self validateIntegerRange.

	lastX _ startX * 256.
	lastY _ startY * 256.
! !

!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 00:26'!
stepToNext
		lastX _ lastX + fwDx.
		lastY _ lastY + fwDy.
		fwDx _ fwDx + fwDDx.
		fwDy _ fwDy + fwDDy.! !

!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 04:01'!
stepToNextInt
	"Scaled integer version of forward differencing"
	self halt.
	(maxSteps >= 0) ifTrue:[
		self validateIntegerRange.
		lastX _ lastX + ((fwDx + 16r8000) // 16r10000).
		lastY _ lastY + ((fwDy + 16r8000) // 16r10000).
		fwDx _ fwDx + fwDDx.
		fwDy _ fwDy + fwDDy.
		maxSteps _ maxSteps - 1.
	].! !

!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 03:27'!
validateIntegerRange
	fwDx class == SmallInteger ifFalse:[self halt].
	fwDy class == SmallInteger ifFalse:[self halt].
	fwDDx class == SmallInteger ifFalse:[self halt].
	fwDDy class == SmallInteger ifFalse:[self halt].
! !

!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/29/1998 21:26'!
valueAt: parameter
	"Return the point at the value parameter:
		p(t) =	(1-t)^2 * p1 + 
				2*t*(1-t) * p2 + 
				t^2 * p3.
	"
	| t1 t2 t3 |
	t1 _ (1.0 - parameter) squared.
	t2 _ 2 * parameter * (1.0 - parameter).
	t3 _ parameter squared.
	^(start * t1) + (via * t2) + (end * t3)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BalloonBezierSimulation class
	instanceVariableNames: ''!

!BalloonBezierSimulation class methodsFor: 'class initialization' stamp: 'ar 10/30/1998 03:04'!
initialize
	"GraphicsBezierSimulation initialize"
	HeightSubdivisions _ 0.
	LineConversions _ 0.
	MonotonSubdivisions _ 0.
	OverflowSubdivisions _ 0.! !
Object variableWordSubclass: #BalloonBuffer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Engine'!
!BalloonBuffer commentStamp: '<historical>' prior: 0!
BalloonBuffer is a repository for primitive data used by the BalloonEngine.!


!BalloonBuffer methodsFor: 'accessing' stamp: 'ar 10/26/1998 21:12'!
at: index
	"For simulation only"
	| word |
	word _ self basicAt: index.
	word < 16r3FFFFFFF ifTrue:[^word]. "Avoid LargeInteger computations"
	^word >= 16r80000000	"Negative?!!"
		ifTrue:["word - 16r100000000"
				(word bitInvert32 + 1) negated]
		ifFalse:[word]! !

!BalloonBuffer methodsFor: 'accessing' stamp: 'ar 10/26/1998 21:12'!
at: index put: anInteger
	"For simulation only"
	| word |
	anInteger < 0
		ifTrue:["word _ 16r100000000 + anInteger"
				word _ (anInteger + 1) negated bitInvert32]
		ifFalse:[word _ anInteger].
	self  basicAt: index put: word.
	^anInteger! !

!BalloonBuffer methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'!
floatAt: index
	"For simulation only"
	<primitive: 'primitiveAt' module: 'FloatArrayPlugin'>
	^Float fromIEEE32Bit: (self basicAt: index)! !

!BalloonBuffer methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'!
floatAt: index put: value
	"For simulation only"
	<primitive: 'primitiveAtPut' module: 'FloatArrayPlugin'>
	value isFloat 
		ifTrue:[self basicAt: index put: value asIEEE32BitWord]
		ifFalse:[self at: index put: value asFloat].
	^value! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BalloonBuffer class
	instanceVariableNames: ''!

!BalloonBuffer class methodsFor: 'instance creation' stamp: 'ar 10/26/1998 21:11'!
mew: n
	^self new: (n max: 256)! !

!BalloonBuffer class methodsFor: 'instance creation' stamp: 'ar 10/26/1998 21:11'!
new
	^self new: 256.! !
FormCanvas subclass: #BalloonCanvas
	instanceVariableNames: 'transform colorTransform engine aaLevel deferred'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Engine'!
!BalloonCanvas commentStamp: '<historical>' prior: 0!
BalloonCanvas is a canvas using the BalloonEngine for drawing wherever possible. It has various methods which other canvases do not support due to the extra features of the balloon engine.!


!BalloonCanvas methodsFor: 'initialize' stamp: 'ar 11/24/1998 15:28'!
flush
	"Force all pending primitives onscreen"
	engine ifNotNil:[engine flush].! !

!BalloonCanvas methodsFor: 'initialize' stamp: 'ar 12/30/1998 10:54'!
initialize
	aaLevel _ 1.
	deferred _ false.! !

!BalloonCanvas methodsFor: 'initialize' stamp: 'ar 11/11/1998 20:25'!
resetEngine
	engine _ nil.! !


!BalloonCanvas methodsFor: 'accessing' stamp: 'ar 11/13/1998 01:02'!
aaLevel
	^aaLevel! !

!BalloonCanvas methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:53'!
aaLevel: newLevel
	"Only allow changes to aaLevel if we're working on >= 8 bit forms"
	form depth >= 8 ifFalse:[^self].
	aaLevel = newLevel ifTrue:[^self].
	self flush.	"In case there are pending primitives in the engine"
	aaLevel _ newLevel.
	engine ifNotNil:[engine aaLevel: aaLevel].! !

!BalloonCanvas methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:54'!
deferred
	^deferred! !

!BalloonCanvas methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:55'!
deferred: aBoolean
	deferred == aBoolean ifTrue:[^self].
	self flush. "Force pending prims on screen"
	deferred _ aBoolean.
	engine ifNotNil:[engine deferred: aBoolean].! !

!BalloonCanvas methodsFor: 'accessing' stamp: 'ar 2/13/2001 21:07'!
ensuredEngine
	engine ifNil:[
		engine _ BalloonEngine new.
		"engine _ BalloonDebugEngine new"
		engine aaLevel: aaLevel.
		engine bitBlt: port.
		engine destOffset: origin.
		engine clipRect: clipRect.
		engine deferred: deferred.
		engine].
	engine colorTransform: colorTransform.
	engine edgeTransform: transform.
	^engine! !


!BalloonCanvas methodsFor: 'testing' stamp: 'ar 11/13/1998 13:19'!
isBalloonCanvas
	^true! !

!BalloonCanvas methodsFor: 'testing' stamp: 'ar 11/12/1998 01:07'!
isVisible: aRectangle
	^transform 
		ifNil:[super isVisible: aRectangle]
		ifNotNil:[super isVisible: (transform localBoundsToGlobal: aRectangle)]! !


!BalloonCanvas methodsFor: 'copying' stamp: 'ar 11/24/1998 22:33'!
copy
	self flush.
	^super copy resetEngine! !


!BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/9/1999 05:40'!
fillColor: c
	"Note: This always fills, even if the color is transparent."
	"Note2: To achieve the above we must make sure that c is NOT transparent"
	self frameAndFillRectangle: form boundingBox 
		fillColor: (c alpha: 1.0)
		borderWidth: 0
		borderColor: nil! !

!BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/9/1999 05:51'!
fillOval: r color: c borderWidth: borderWidth borderColor: borderColor
	"Draw a filled and outlined oval"
	"Note: The optimization test below should actually read:
		self ifNoTransformWithIn: (r insetBy: borderWidth // 2)
	but since borderWidth is assumed to be very small related to r we don't check it."

	(self ifNoTransformWithIn: r)
		ifTrue:[^super fillOval: r color: c borderWidth: borderWidth borderColor: borderColor].

	^self drawOval: (r insetBy: borderWidth // 2) 
			color: c 
			borderWidth: borderWidth 
			borderColor: borderColor! !

!BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/9/1999 05:40'!
fillRectangle: r color: c
	"Fill the rectangle with the given color"
	^self frameAndFillRectangle: r
			fillColor: c
			borderWidth: 0
			borderColor: nil! !

!BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/9/1999 06:26'!
frameAndFillRectangle: r fillColor: c borderWidth: borderWidth borderColor: borderColor
	"Draw a filled and outlined rectangle"
	"Note: The optimization test below should actually read:
		self ifNoTransformWithIn: (r insetBy: borderWidth // 2)
	but since borderWidth is assumed to be very small related to r we don't check it."

	(self ifNoTransformWithIn: r)
		ifTrue:[^super frameAndFillRectangle: r fillColor: c borderWidth: borderWidth borderColor: borderColor].

	^self drawRectangle: (r insetBy: borderWidth // 2) 
			color: c 
			borderWidth: borderWidth 
			borderColor: borderColor! !

!BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/9/1999 05:52'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor
	"Draw a beveled or raised rectangle"
	| bw |

	"Note: The optimization test below should actually read:
		self ifNoTransformWithIn: (r insetBy: borderWidth // 2)
	but since borderWidth is assumed to be very small related to r we don't check it."

	(self ifNoTransformWithIn: r)
		ifTrue:[^super frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor].

	"Fill rectangle and draw top and left border"
	bw _ borderWidth // 2.
	self drawRectangle: (r insetBy: bw)
		color: fillColor
		borderWidth: borderWidth
		borderColor: topLeftColor.
	"Now draw bottom right border."
	self drawPolygon: (Array with: r topRight + (bw negated@bw) 
							with: r bottomRight - bw asPoint
							with: r bottomLeft + (bw@bw negated))
		color: nil
		borderWidth: borderWidth
		borderColor: bottomRightColor.! !

!BalloonCanvas methodsFor: 'drawing' stamp: 'nk 5/1/2004 12:25'!
frameRectangle: r width: w color: c
	"Draw a frame around the given rectangle"
	^self frameAndFillRectangle: r
			fillColor: Color transparent
			borderWidth: w
			borderColor: c! !

!BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/12/1999 17:45'!
line: pt1 to: pt2 width: w color: c
	"Draw a line from pt1 to: pt2"
	(self ifNoTransformWithIn:(pt1 rect: pt2))
		ifTrue:[^super line: pt1 to: pt2 width: w color: c].
	^self drawPolygon: (Array with: pt1 with: pt2)
		color: c
		borderWidth: w
		borderColor: c! !

!BalloonCanvas methodsFor: 'drawing' stamp: 'ar 11/11/1998 19:39'!
point: pt color: c
	"Is there any use for this?"
	| myPt |
	transform 
		ifNil:[myPt _ pt]
		ifNotNil:[myPt _ transform localPointToGlobal: pt].
	^super point: myPt color: c! !


!BalloonCanvas methodsFor: 'balloon drawing' stamp: 'DSM 10/15/1999 15:14'!
drawBezier3Shape: vertices color: c borderWidth: borderWidth borderColor:
borderColor
	self drawBezierShape: (Bezier3Segment convertBezier3ToBezier2:
vertices) color: c borderWidth: borderWidth borderColor: borderColor! !

!BalloonCanvas methodsFor: 'balloon drawing' stamp: 'ar 2/17/2000 00:25'!
drawBezierShape: vertices color: c borderWidth: borderWidth borderColor: borderColor
	"Draw a boundary shape that is defined by a list of vertices.
	Each three subsequent vertices define a quadratic bezier segment.
	For lines, the control point should be set to either the start or the end
	of the bezier curve."
	| fillC borderC |
	fillC _ self shadowColor ifNil:[c].
	borderC _ self shadowColor ifNil:[borderColor].
	self ensuredEngine
		drawBezierShape: vertices
		fill: fillC
		borderWidth: borderWidth
		borderColor: borderC
		transform: transform.! !

!BalloonCanvas methodsFor: 'balloon drawing' stamp: 'ar 11/24/1998 15:16'!
drawCompressedShape: compressedShape
	"Draw a compressed shape"
	self ensuredEngine
		drawCompressedShape: compressedShape
		transform: transform.! !

!BalloonCanvas methodsFor: 'balloon drawing' stamp: 'DSM 10/15/1999 15:18'!
drawGeneralBezier3Shape: contours color: c borderWidth: borderWidth
borderColor: borderColor
	| b2 |
	b2 _ contours collect: [:b3 | Bezier3Segment
convertBezier3ToBezier2: b3 ].
	self drawGeneralBezierShape: b2 color: c borderWidth: borderWidth
borderColor: borderColor! !

!BalloonCanvas methodsFor: 'balloon drawing' stamp: 'ar 2/17/2000 00:24'!
drawGeneralBezierShape: contours color: c borderWidth: borderWidth borderColor: borderColor
	"Draw a general boundary shape (e.g., possibly containing holes)"
	| fillC borderC |
	fillC _ self shadowColor ifNil:[c].
	borderC _ self shadowColor ifNil:[borderColor].
	self ensuredEngine
		drawGeneralBezierShape: contours
		fill: fillC
		borderWidth: borderWidth
		borderColor: borderC
		transform: transform.! !

!BalloonCanvas methodsFor: 'balloon drawing' stamp: 'ar 2/17/2000 00:24'!
drawGeneralPolygon: contours color: c borderWidth: borderWidth borderColor: borderColor
	"Draw a general polygon (e.g., a polygon that can contain holes)"
	| fillC borderC |
	fillC _ self shadowColor ifNil:[c].
	borderC _ self shadowColor ifNil:[borderColor].
	self ensuredEngine
		drawGeneralPolygon: contours
		fill: fillC
		borderWidth: borderWidth
		borderColor: borderC
		transform: transform.! !

!BalloonCanvas methodsFor: 'balloon drawing' stamp: 'ar 2/17/2000 00:24'!
drawOval: r color: c borderWidth: borderWidth borderColor: borderColor
	"Draw the oval defined by the given rectangle"
	| fillC borderC |
	fillC _ self shadowColor ifNil:[c].
	borderC _ self shadowColor ifNil:[borderColor].
	self ensuredEngine
		drawOval: r
		fill: fillC
		borderWidth: borderWidth
		borderColor: borderC
		transform: transform.! !

!BalloonCanvas methodsFor: 'balloon drawing' stamp: 'ar 2/17/2000 00:24'!
drawRectangle: r color: c borderWidth: borderWidth borderColor: borderColor
	"Draw a rectangle"
	| fillC borderC |
	fillC _ self shadowColor ifNil:[c].
	borderC _ self shadowColor ifNil:[borderColor].
	self ensuredEngine
		drawRectangle: r
		fill: fillC
		borderWidth: borderWidth
		borderColor: borderC
		transform: transform.! !


!BalloonCanvas methodsFor: 'TODO' stamp: 'ar 12/31/2001 02:27'!
drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c
	(self ifNoTransformWithIn: boundsRect)
		ifTrue:[^super drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c]! !

!BalloonCanvas methodsFor: 'TODO' stamp: 'ar 2/9/1999 05:46'!
line: point1 to: point2 brushForm: brush
	"Who's gonna use this?"
	| pt1 pt2 |
	self flush. "Sorry, but necessary..."
	transform 
		ifNil:[pt1 _ point1. pt2 _ point2]
		ifNotNil:[pt1 _ transform localPointToGlobal: point1.
				pt2 _ transform localPointToGlobal: point2].
	^super line: pt1 to: pt2 brushForm: brush! !

!BalloonCanvas methodsFor: 'TODO' stamp: 'ar 2/9/1999 05:46'!
paragraph: para bounds: bounds color: c
	(self ifNoTransformWithIn: bounds)
		ifTrue:[^super paragraph: para bounds: bounds color: c].! !


!BalloonCanvas methodsFor: 'transforming' stamp: 'ar 11/24/1998 14:45'!
colorTransformBy: aColorTransform
	aColorTransform ifNil:[^self].
	colorTransform 
		ifNil:[colorTransform _ aColorTransform]
		ifNotNil:[colorTransform _ colorTransform composedWithLocal: aColorTransform]! !

!BalloonCanvas methodsFor: 'transforming' stamp: 'ar 12/30/1998 10:47'!
preserveStateDuring: aBlock
	| state result |
	state _ BalloonState new.
	state transform: transform.
	state colorTransform: colorTransform.
	state aaLevel: self aaLevel.
	result _ aBlock value: self.
	transform _ state transform.
	colorTransform _ state colorTransform.
	self aaLevel: state aaLevel.
	^result! !

!BalloonCanvas methodsFor: 'transforming' stamp: 'ar 11/12/1998 00:32'!
transformBy: aTransform
	aTransform ifNil:[^self].
	transform 
		ifNil:[transform _ aTransform]
		ifNotNil:[transform _ transform composedWithLocal: aTransform]! !

!BalloonCanvas methodsFor: 'transforming' stamp: 'ar 5/29/1999 08:59'!
transformBy: aDisplayTransform during: aBlock
	| myTransform result |
	myTransform _ transform.
	self transformBy: aDisplayTransform.
	result _ aBlock value: self.
	transform _ myTransform.
	^result! !


!BalloonCanvas methodsFor: 'private' stamp: 'ar 2/9/1999 06:29'!
ifNoTransformWithIn: box
	"Return true if the current transformation does not affect the given bounding box"
	| delta |
	"false ifFalse:[^false]."
	transform isNil ifTrue:[^true].
	delta _ (transform localPointToGlobal: box origin) - box origin.
	^(transform localPointToGlobal: box corner) - box corner = delta! !

!BalloonCanvas methodsFor: 'private' stamp: 'nk 5/1/2004 12:54'!
image: aForm at: aPoint sourceRect: sourceRect rule: rule
	| warp dstRect srcQuad dstOffset center |
	(self ifNoTransformWithIn: sourceRect) & false
		ifTrue:[^super image: aForm at: aPoint sourceRect: sourceRect rule: rule].
	dstRect _ (transform localBoundsToGlobal: (aForm boundingBox translateBy: aPoint)).
	dstOffset _ 0@0. "dstRect origin."
	"dstRect _ 0@0 corner: dstRect extent."
	center _ 0@0."transform globalPointToLocal: dstRect origin."
	srcQuad _ transform globalPointsToLocal: (dstRect innerCorners).
	srcQuad _ srcQuad collect:[:pt| pt - aPoint].
	warp _ (WarpBlt current toForm: form)
			sourceForm: aForm;
			cellSize: 2;  "installs a new colormap if cellSize > 1"
			combinationRule: Form over.
	warp copyQuad: srcQuad toRect: (dstRect translateBy: dstOffset).

	self frameRectangle: (aForm boundingBox translateBy: aPoint) color: Color green.

	"... TODO ... create a bitmap fill style from the form and use it for a simple rectangle."! !


!BalloonCanvas methodsFor: 'converting' stamp: 'ar 11/11/1998 22:57'!
asBalloonCanvas
	^self! !


!BalloonCanvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/18/1999 08:48'!
fillRectangle: aRectangle fillStyle: aFillStyle
	"Fill the given rectangle."
	^self drawRectangle: aRectangle
			color: aFillStyle "@@: Name confusion!!!!!!"
			borderWidth: 0
			borderColor: nil
! !


!BalloonCanvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:50'!
fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
	"Fill the given rectangle."
	^self drawOval: (aRectangle insetBy: bw // 2)
			color: aFillStyle "@@: Name confusion!!!!!!"
			borderWidth: bw
			borderColor: bc
! !


!BalloonCanvas methodsFor: 'drawing-polygons' stamp: 'ar 8/26/2001 22:14'!
drawPolygon: vertices fillStyle: aFillStyle
	"Fill the given polygon."
	self drawPolygon: vertices fillStyle: aFillStyle borderWidth: 0 borderColor: nil! !

!BalloonCanvas methodsFor: 'drawing-polygons' stamp: 'ar 2/17/2000 00:25'!
drawPolygon: vertices fillStyle: aFillStyle borderWidth: borderWidth borderColor: borderColor
	"Draw a simple polygon defined by the list of vertices."
	| fillC borderC |
	fillC _ self shadowColor ifNil:[aFillStyle].
	borderC _ self shadowColor ifNil:[borderColor].
	self ensuredEngine
		drawPolygon: (vertices copyWith: vertices first)
		fill: fillC
		borderWidth: borderWidth
		borderColor: borderC
		transform: transform.! !

Object subclass: #BalloonEdgeData
	instanceVariableNames: 'index xValue yValue zValue lines source'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Simulation'!
!BalloonEdgeData commentStamp: '<historical>' prior: 0!
BalloonEdgeData defines an entry in the internal edge table of the Balloon engine.

Instance Variables:
	index	<Integer>	The index into the external objects array of the associated graphics engine
	xValue	<Integer>	The computed x-value of the requested operation
	yValue	<Integer>	The y-value for the requested operation
	height	<Integer>	The (remaining) height of the edge
	source	<Object>		The object from the external objects array!


!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:34'!
index
	^index! !

!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:35'!
index: anInteger
	index _ anInteger! !

!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:13'!
lines
	^lines! !

!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:13'!
lines: anInteger
	^lines _ anInteger! !

!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:34'!
source
	^source! !

!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 21:39'!
source: anObject
	source _ anObject! !

!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:34'!
xValue
	^xValue! !

!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:35'!
xValue: anInteger
	xValue _ anInteger! !

!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:34'!
yValue
	^yValue! !

!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:35'!
yValue: anInteger
	yValue _ anInteger! !

!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 19:56'!
zValue
	^zValue! !

!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 19:56'!
zValue: anInteger
	zValue _ anInteger! !


!BalloonEdgeData methodsFor: 'computing' stamp: 'ar 10/27/1998 15:53'!
stepToFirstScanLine
	source stepToFirstScanLineAt: yValue in: self! !

!BalloonEdgeData methodsFor: 'computing' stamp: 'ar 10/27/1998 15:53'!
stepToNextScanLine
	source stepToNextScanLineAt: yValue in: self! !
Object subclass: #BalloonEngine
	instanceVariableNames: 'workBuffer span bitBlt forms clipRect destOffset externals aaLevel edgeTransform colorTransform deferred postFlushNeeded'
	classVariableNames: 'BezierStats BufferCache CacheProtect Counts Debug Times'
	poolDictionaries: 'BalloonEngineConstants'
	category: 'Balloon-Engine'!
!BalloonEngine commentStamp: '<historical>' prior: 0!
BalloonEngine is the representative for the Balloon engine inside Squeak. For most purposes it should not be used directly but via BalloonCanvas since this ensures proper initialization and is polymorphic with other canvas uses.!


!BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 22:29'!
flush
	"Force all pending primitives onscreen"
	workBuffer ifNil:[^self].
	self copyBits.
	self release.! !

!BalloonEngine methodsFor: 'initialize' stamp: 'nk 9/26/2003 10:52'!
initialize
	| w |
	w _ Display width > 2048 ifTrue: [ 4096 ] ifFalse: [ 2048 ].
	externals _ OrderedCollection new: 100.
	span _ Bitmap new: w.
	bitBlt _ nil.
	self bitBlt: ((BitBlt toForm: Display) destRect: Display boundingBox; yourself).
	forms _ #().
	deferred _ false.! !

!BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 22:42'!
postFlushIfNeeded
	"Force all pending primitives onscreen"
	workBuffer ifNil:[^self].
	(deferred not or:[postFlushNeeded]) ifTrue:[
		self copyBits.
		self release].! !

!BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 22:43'!
preFlushIfNeeded
	"Force all pending primitives onscreen"
	workBuffer ifNil:[^self].
	self primFlushNeeded ifTrue:[
		self copyBits.
		self reset].! !

!BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/11/1998 22:52'!
release
	self class recycleBuffer: workBuffer.
	workBuffer _ nil.! !

!BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 22:34'!
reset
	workBuffer ifNil:[workBuffer _ self class allocateOrRecycleBuffer: 10000].
	self primInitializeBuffer: workBuffer.
	self primSetAALevel: self aaLevel.
	self primSetOffset: destOffset.
	self primSetClipRect: clipRect.
	self primSetEdgeTransform: edgeTransform.
	self primSetColorTransform: colorTransform.
	forms _ #().! !

!BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 22:39'!
resetIfNeeded
	workBuffer ifNil:[self reset].
	self primSetEdgeTransform: edgeTransform.
	self primSetColorTransform: colorTransform.
	self primSetDepth: self primGetDepth + 1.
	postFlushNeeded _ false.! !


!BalloonEngine methodsFor: 'drawing' stamp: 'ar 10/11/1999 16:49'!
drawBezierShape: points fill: fillStyle borderWidth: borderWidth borderColor: borderFill transform: aTransform
	| fills |
	self edgeTransform: aTransform.
	self resetIfNeeded.
	fills _ self registerFill: fillStyle and: borderFill.
	self primAddBezierShape: points
		segments: (points size) // 3
		fill: (fills at: 1)
		lineWidth: borderWidth
		lineFill: (fills at: 2).
	self postFlushIfNeeded.! !

!BalloonEngine methodsFor: 'drawing' stamp: 'ar 11/26/1998 19:44'!
drawCompressedShape: shape transform: aTransform
	| fillIndexList |
	self edgeTransform: aTransform.
	self resetIfNeeded.

	fillIndexList _ self registerFills: shape fillStyles.

	self primAddCompressedShape: shape points
		segments: shape numSegments
		leftFills: shape leftFills
		rightFills: shape rightFills
		lineWidths: shape lineWidths
		lineFills: shape lineFills
		fillIndexList: fillIndexList.
	self postFlushIfNeeded.! !

!BalloonEngine methodsFor: 'drawing' stamp: 'ar 1/15/1999 03:02'!
drawGeneralBezierShape: contours fill: fillStyle borderWidth: borderWidth borderColor: borderFill transform: aTransform

	| fills |
	self edgeTransform: aTransform.
	self resetIfNeeded.
	fills _ self registerFill: fillStyle and: borderFill.
	contours do:[:points|
		self primAddBezierShape: points
			segments: (points size // 3)
			fill: (fills at: 1)
			lineWidth: borderWidth
			lineFill: (fills at: 2).
		"Note: To avoid premature flushing of the pipeline we need to
		reset the flush bit within the engine."
		self primFlushNeeded: false.
	].
	"And set the flush bit afterwards"
	self primFlushNeeded: true.
	self postFlushIfNeeded.! !

!BalloonEngine methodsFor: 'drawing' stamp: 'ar 1/15/1999 03:02'!
drawGeneralPolygon: contours fill: fillStyle borderWidth: borderWidth borderColor: borderFill transform: aTransform

	| fills |
	self edgeTransform: aTransform.
	self resetIfNeeded.
	fills _ self registerFill: fillStyle and: borderFill.
	contours do:[:points|
		self primAddPolygon: points
			segments: points size
			fill: (fills at: 1)
			lineWidth: borderWidth
			lineFill: (fills at: 2).
		"Note: To avoid premature flushing of the pipeline we need to
		reset the flush bit within the engine."
		self primFlushNeeded: false.
	].
	"And set the flush bit afterwards"
	self primFlushNeeded: true.
	self postFlushIfNeeded.! !

!BalloonEngine methodsFor: 'drawing' stamp: 'ar 11/26/1998 19:45'!
drawOval: rect fill: fillStyle borderWidth: borderWidth borderColor: borderColor transform: aMatrix

	| fills |
	self edgeTransform: aMatrix.
	self resetIfNeeded.
	fills _ self registerFill: fillStyle and: borderColor.
	self primAddOvalFrom: rect origin 
			to: rect corner
			fillIndex: (fills at: 1)
			borderWidth: borderWidth
			borderColor: (fills at: 2).
	self postFlushIfNeeded.! !

!BalloonEngine methodsFor: 'drawing' stamp: 'ar 11/26/1998 19:45'!
drawPolygon: points fill: fillStyle borderWidth: borderWidth borderColor: borderFill transform: aTransform

	| fills |
	self edgeTransform: aTransform.
	self resetIfNeeded.
	fills _ self registerFill: fillStyle and: borderFill.
	self primAddPolygon: points
		segments: points size
		fill: (fills at: 1)
		lineWidth: borderWidth
		lineFill: (fills at: 2).
	self postFlushIfNeeded.! !

!BalloonEngine methodsFor: 'drawing' stamp: 'ar 11/26/1998 19:45'!
drawRectangle: rect fill: fillStyle borderWidth: borderWidth borderColor: borderColor transform: aMatrix

	| fills |
	self edgeTransform: aMatrix.
	self resetIfNeeded.
	fills _ self registerFill: fillStyle and: borderColor.
	self primAddRectFrom: rect origin 
			to: rect corner
			fillIndex: (fills at: 1)
			borderWidth: borderWidth
			borderColor: (fills at: 2).
	self postFlushIfNeeded.! !

!BalloonEngine methodsFor: 'drawing' stamp: 'ar 1/14/1999 15:24'!
registerFill: aFillStyle
	"Register the given fill style."
	| theForm |
	aFillStyle ifNil:[^0].
	aFillStyle isSolidFill 
		ifTrue:[^aFillStyle scaledPixelValue32].

	aFillStyle isGradientFill ifTrue:[
		^self primAddGradientFill: aFillStyle pixelRamp
			from: aFillStyle origin
			along: aFillStyle direction
			normal: aFillStyle normal
			radial: aFillStyle isRadialFill
		].
	aFillStyle isBitmapFill ifTrue:[
		theForm _ aFillStyle form.
		theForm unhibernate.
		forms _ forms copyWith: theForm.
		^self primAddBitmapFill: theForm
				colormap: (theForm colormapIfNeededForDepth: 32)
				tile: aFillStyle isTiled
				from: aFillStyle origin
				along: aFillStyle direction
				normal: aFillStyle normal
				xIndex: forms size].
	^0! !

!BalloonEngine methodsFor: 'drawing' stamp: 'ar 11/26/1998 19:45'!
registerFill: fill1 and: fill2
	^self registerFills: (Array with: fill1 with: fill2)! !

!BalloonEngine methodsFor: 'drawing' stamp: 'ar 1/14/1999 15:24'!
registerFill: aFillStyle transform: aTransform

	aFillStyle ifNil:[^0].
	aFillStyle isSolidFill 
		ifTrue:[^aFillStyle scaledPixelValue32].

	aFillStyle isGradientFill ifTrue:[
		^self primAddGradientFill: aFillStyle pixelRamp
			from: aFillStyle origin
			along: aFillStyle direction
			normal: aFillStyle normal
			radial: aFillStyle isRadialFill
			matrix: aTransform.
		].
	^0! !

!BalloonEngine methodsFor: 'drawing' stamp: 'di 11/21/1999 20:15'!
registerFills: fills

	| fillIndexList index fillIndex |
	((colorTransform notNil and:[colorTransform isAlphaTransform]) or:[
		fills anySatisfy: [:any| any notNil and:[any isTranslucent]]])
			ifTrue:[	self flush.
					self reset.
					postFlushNeeded _ true].
	fillIndexList _ WordArray new: fills size.
	index _ 1.
	[index <= fills size] whileTrue:[
		fillIndex _ self registerFill: (fills at: index).
		fillIndex == nil 
			ifTrue:[index _ 1] "Need to start over"
			ifFalse:[fillIndexList at: index put: fillIndex.
					index _ index+1]
	].
	^fillIndexList! !


!BalloonEngine methodsFor: 'copying' stamp: 'ar 11/25/1998 00:45'!
canProceedAfter: failureReason
	"Check if we can proceed after the failureReason indicated."
	| newBuffer |
	failureReason = GErrorNeedFlush ifTrue:[
		"Need to flush engine before proceeding"
		self copyBits.
		self reset.
		^true].
	failureReason = GErrorNoMoreSpace ifTrue:[
		"Work buffer is too small"
		newBuffer _ workBuffer species new: workBuffer size * 2.
		self primCopyBufferFrom: workBuffer to: newBuffer.
		workBuffer _ newBuffer.
		^true].
	"Not handled"
	^false! !

!BalloonEngine methodsFor: 'copying' stamp: 'ar 3/6/2001 12:06'!
copyBits
	(bitBlt notNil and:[bitBlt destForm notNil]) ifTrue:[bitBlt destForm unhibernate].
	self copyLoopFaster.! !

!BalloonEngine methodsFor: 'copying' stamp: 'ar 11/14/1998 19:32'!
copyLoop
	"This is the basic rendering loop using as little primitive support as possible."
	| finished edge fill |
	edge _ BalloonEdgeData new.
	fill _ BalloonFillData new.
	self primInitializeProcessing. "Initialize the GE for processing"
	[self primFinishedProcessing] whileFalse:[
		"Step 1: Process the edges in the global edge table that will be added in this step"
		[finished _ self primNextGlobalEdgeEntryInto: edge.
		finished] whileFalse:[
			edge source: (externals at: edge index).
			edge stepToFirstScanLine.
			self primAddActiveEdgeTableEntryFrom: edge].

		"Step 2: Scan the active edge table"
		[finished _ self primNextFillEntryInto: fill.
		finished] whileFalse:[
			fill source: (externals at: fill index).
			"Compute the new fill"
			fill computeFill.
			"And mix it in the out buffer"
			self primMergeFill: fill destForm bits from: fill].

		"Step 3: Display the current span buffer if necessary"
		self primDisplaySpanBuffer.

		"Step 4: Advance and resort the active edge table"
		[finished _ self primNextActiveEdgeEntryInto: edge.
		finished] whileFalse:[
			"If the index is zero then the edge has been handled by the GE"
			edge source: (externals at: edge index).
			edge stepToNextScanLine.
			self primChangeActiveEdgeTableEntryFrom: edge].
	].
	self primGetTimes: Times.
	self primGetCounts: Counts.
	self primGetBezierStats: BezierStats.! !

!BalloonEngine methodsFor: 'copying' stamp: 'ar 11/14/1998 19:32'!
copyLoopFaster
	"This is a copy loop drawing one scan line at a time"
	| edge fill reason |
	edge _ BalloonEdgeData new.
	fill _ BalloonFillData new.
	[self primFinishedProcessing] whileFalse:[
		reason _ self primRenderScanline: edge with: fill.
		"reason ~= 0 means there has been a problem"
		reason = 0 ifFalse:[
			self processStopReason: reason edge: edge fill: fill.
		].
	].
	self primGetTimes: Times.
	self primGetCounts: Counts.
	self primGetBezierStats: BezierStats.! !

!BalloonEngine methodsFor: 'copying' stamp: 'ar 11/14/1998 19:33'!
copyLoopFastest
	"This is a copy loop drawing the entire image"
	| edge fill reason |
	edge _ BalloonEdgeData new.
	fill _ BalloonFillData new.
	[self primFinishedProcessing] whileFalse:[
		reason _ self primRenderImage: edge with: fill.
		"reason ~= 0 means there has been a problem"
		reason = 0 ifFalse:[
			self processStopReason: reason edge: edge fill: fill.
		].
	].
	self primGetTimes: Times.
	self primGetCounts: Counts.
	self primGetBezierStats: BezierStats.! !

!BalloonEngine methodsFor: 'copying' stamp: 'ar 11/11/1998 21:19'!
processStopReason: reason edge: edge fill: fill
	"The engine has stopped because of some reason.
	Try to figure out how to respond and do the necessary actions."
	"Note: The order of operations below can affect the speed"

	"Process unknown fills first"
	reason = GErrorFillEntry ifTrue:[
		fill source: (externals at: fill index).
		"Compute the new fill"
		fill computeFill.
		"And mix it in the out buffer"
		^self primMergeFill: fill destForm bits from: fill].

	"Process unknown steppings in the AET second"
	reason = GErrorAETEntry ifTrue:[
		edge source: (externals at: edge index).
		edge stepToNextScanLine.
		^self primChangeActiveEdgeTableEntryFrom: edge].

	"Process unknown entries in the GET third"
	reason = GErrorGETEntry ifTrue:[
		edge source: (externals at: edge index).
		edge stepToFirstScanLine.
		^self primAddActiveEdgeTableEntryFrom: edge].

	"Process generic problems last"
	(self canProceedAfter: reason) ifTrue:[^self]. "Okay."

	^self error:'Unkown stop reason in graphics engine'
! !


!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/11/1998 23:04'!
aaLevel
	^aaLevel ifNil:[1]! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/11/1998 23:04'!
aaLevel: anInteger
	aaLevel _ (anInteger min: 4) max: 1.! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 10/29/1998 01:51'!
aaTransform
	"Return a transformation for the current anti-aliasing level"
	| matrix |
	matrix _ MatrixTransform2x3 withScale: (self aaLevel) asFloat asPoint.
	matrix offset: (self aaLevel // 2) asFloat asPoint.
	^matrix composedWith:(MatrixTransform2x3 withOffset: destOffset asFloatPoint)! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 10/13/1998 03:04'!
bitBlt
	^bitBlt! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 5/28/2000 15:02'!
bitBlt: aBitBlt
	bitBlt _ aBitBlt.
	bitBlt isNil ifTrue:[^self].
	self class primitiveSetBitBltPlugin: bitBlt getPluginName.
	self clipRect: bitBlt clipRect.
	bitBlt 
		sourceForm: (Form extent: span size @ 1 depth: 32 bits: span);
		sourceRect: (0@0 extent: 1@span size);
		colorMap: (Color colorMapIfNeededFrom: 32 to: bitBlt destForm depth);
		combinationRule: (bitBlt destForm depth >= 8 ifTrue:[34] ifFalse:[Form paint]).! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/1/1998 02:57'!
clipRect
	^clipRect! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 10/13/1998 02:44'!
clipRect: aRect
	clipRect _ aRect truncated! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/24/1998 15:04'!
colorTransform
	^colorTransform! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/24/1998 15:04'!
colorTransform: aColorTransform
	colorTransform _ aColorTransform! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 12/30/1998 11:24'!
deferred
	^deferred! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 12/30/1998 11:24'!
deferred: aBoolean
	deferred _ aBoolean.! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/1/1998 02:56'!
destOffset
	^destOffset! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/12/1998 00:22'!
destOffset: aPoint
	destOffset _ aPoint asIntegerPoint.
	bitBlt destX: aPoint x; destY: aPoint y.! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/25/1998 22:34'!
edgeTransform
	^edgeTransform! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/25/1998 22:34'!
edgeTransform: aTransform
	edgeTransform _ aTransform.! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 10/29/1998 01:51'!
fullTransformFrom: aMatrix
	| m |
	m _ self aaTransform composedWith: aMatrix.
	"m offset: m offset + destOffset."
	^m! !


!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:48'!
primClipRectInto: rect
	<primitive: 'primitiveGetClipRect' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'!
primFlushNeeded
	<primitive: 'primitiveNeedsFlush' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'!
primFlushNeeded: aBoolean
	<primitive: 'primitiveNeedsFlushPut' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'!
primGetAALevel
	"Set the AA level"
	<primitive: 'primitiveGetAALevel' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'!
primGetBezierStats: statsArray
	<primitive: 'primitiveGetBezierStats' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'!
primGetClipRect: rect
	<primitive: 'primitiveGetClipRect' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'!
primGetCounts: statsArray
	<primitive: 'primitiveGetCounts' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'!
primGetDepth
	<primitive: 'primitiveGetDepth' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'!
primGetFailureReason
	<primitive: 'primitiveGetFailureReason' module: 'B2DPlugin'>
	^0! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'!
primGetOffset
	<primitive: 'primitiveGetOffset' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'!
primGetTimes: statsArray
	<primitive: 'primitiveGetTimes' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'!
primSetAALevel: level
	"Set the AA level"
	<primitive: 'primitiveSetAALevel' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'!
primSetClipRect: rect
	<primitive: 'primitiveSetClipRect' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'!
primSetColorTransform: transform
	<primitive: 'primitiveSetColorTransform' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'!
primSetDepth: depth
	<primitive: 'primitiveSetDepth' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'!
primSetEdgeTransform: transform
	<primitive: 'primitiveSetEdgeTransform' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'!
primSetOffset: point
	<primitive: 'primitiveSetOffset' module: 'B2DPlugin'>
	^self primitiveFailed! !


!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'!
primAddBezierFrom: start to: end via: via leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex
	<primitive: 'primitiveAddBezier' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddBezierFrom: start to: end via: via leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'!
primAddBezierShape: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill
	<primitive: 'primitiveAddBezierShape' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddBezierShape: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'!
primAddBitmapFill: form colormap: cmap tile: tileFlag from: origin along: direction normal: normal xIndex: xIndex
	<primitive: 'primitiveAddBitmapFill' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddBitmapFill: form colormap: cmap tile: tileFlag from: origin along: direction normal: normal xIndex: xIndex
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'!
primAddCompressedShape: points segments: nSegments leftFills: leftFills rightFills: rightFills lineWidths: lineWidths lineFills: lineFills fillIndexList: fillIndexList
	<primitive: 'primitiveAddCompressedShape' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddCompressedShape: points segments: nSegments leftFills: leftFills rightFills: rightFills lineWidths: lineWidths lineFills: lineFills fillIndexList: fillIndexList
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'!
primAddExternalEdge: index initialX: initialX initialY: initialY initialZ: initialZ leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex
	<primitive: 'primitiveRegisterExternalEdge' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddExternalEdge: index initialX: initialX initialY: initialY initialZ: initialZ leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'!
primAddExternalFill: index
	<primitive: 'primitiveRegisterExternalFill' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddExternalFill: index
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'!
primAddGradientFill: colorRamp from: origin along: direction normal: normal radial: isRadial
	<primitive: 'primitiveAddGradientFill' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddGradientFill: colorRamp 
				from: origin 
				along: direction 
				normal: normal 
				radial: isRadial
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'!
primAddLineFrom: start to: end leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex
	<primitive: 'primitiveAddLine' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddLineFrom: start to: end leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'!
primAddOvalFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32
	<primitive: 'primitiveAddOval' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddOvalFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'!
primAddPolygon: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill
	<primitive: 'primitiveAddPolygon' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddPolygon: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'!
primAddRectFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32
	<primitive: 'primitiveAddRect' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddRectFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32
	].
	^self primitiveFailed! !


!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:48'!
primAddActiveEdgeTableEntryFrom: edgeEntry
	"Add edge entry to the AET."
	<primitive: 'primitiveAddActiveEdgeEntry' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddActiveEdgeTableEntryFrom: edgeEntry
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:48'!
primChangeActiveEdgeTableEntryFrom: edgeEntry
	"Change the entry in the active edge table from edgeEntry"
	<primitive: 'primitiveChangedActiveEdgeEntry' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:48'!
primDisplaySpanBuffer
	"Display the current scan line if necessary"
	<primitive: 'primitiveDisplaySpanBuffer' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'!
primFinishedProcessing
	"Return true if there are no more entries in AET and GET and the last scan line has been displayed"
	<primitive: 'primitiveFinishedProcessing' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'!
primInitializeProcessing
	"Initialize processing in the GE.
	Create the active edge table and sort it."
	<primitive: 'primitiveInitializeProcessing' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'!
primMergeFill: fillBitmap from: fill
	"Merge the filled bitmap into the current output buffer."
	<primitive: 'primitiveMergeFillFrom' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'!
primNextActiveEdgeEntryInto: edgeEntry
	"Store the next entry of the AET at the current y-value in edgeEntry.
	Return false if there is no entry, true otherwise."
	<primitive: 'primitiveNextActiveEdgeEntry' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'!
primNextFillEntryInto: fillEntry
	"Store the next fill entry of the active edge table in fillEntry.
	Return false if there is no such entry, true otherwise"
	<primitive: 'primitiveNextFillEntry' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'!
primNextGlobalEdgeEntryInto: edgeEntry
	"Store the next entry of the GET at the current y-value in edgeEntry.
	Return false if there is no entry, true otherwise."
	<primitive: 'primitiveNextGlobalEdgeEntry' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'!
primRenderImage: edge with: fill
	"Start/Proceed rendering the current scan line"
	<primitive: 'primitiveRenderImage' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'!
primRenderScanline: edge with: fill
	"Start/Proceed rendering the current scan line"
	<primitive: 'primitiveRenderScanline' module: 'B2DPlugin'>
	^self primitiveFailed! !


!BalloonEngine methodsFor: 'primitives-misc' stamp: 'ar 2/2/2001 15:48'!
primCopyBufferFrom: oldBuffer to: newBuffer
	"Copy the contents of oldBuffer into the (larger) newBuffer"
	<primitive: 'primitiveCopyBuffer' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-misc' stamp: 'ar 2/2/2001 15:49'!
primInitializeBuffer: buffer
	<primitive: 'primitiveInitializeBuffer' module: 'B2DPlugin'>
	^self primitiveFailed! !


!BalloonEngine methodsFor: 'experimental' stamp: 'ar 11/12/1998 19:53'!
registerBezier: aCurve transformation: aMatrix
	self primAddBezierFrom: aCurve start
		to: aCurve end
		via: aCurve via
		leftFillIndex: (self registerFill: aCurve leftFill transform: aMatrix)
		rightFillIndex: (self registerFill: aCurve rightFill transform: aMatrix)
		matrix: aMatrix! !

!BalloonEngine methodsFor: 'experimental' stamp: 'ar 11/11/1998 21:15'!
registerBoundary: boundaryObject transformation: aMatrix
	| external |
	external _ boundaryObject asEdgeRepresentation: (self fullTransformFrom: aMatrix).
	self subdivideExternalEdge: external from: boundaryObject.
! !

!BalloonEngine methodsFor: 'experimental' stamp: 'ar 11/12/1998 19:54'!
registerExternalEdge: externalEdge from: boundaryObject
	externals addLast: externalEdge.
	self primAddExternalEdge: externals size
		initialX: externalEdge initialX
		initialY: externalEdge initialY
		initialZ: externalEdge initialZ
		leftFillIndex: (self registerFill: boundaryObject leftFill transform: nil)
		rightFillIndex: (self registerFill: boundaryObject rightFill transform: nil)! !

!BalloonEngine methodsFor: 'experimental' stamp: 'ar 11/12/1998 19:54'!
registerLine: aLine transformation: aMatrix
	self primAddLineFrom: aLine start to: aLine end
		leftFillIndex: (self registerFill: aLine leftFill transform: aMatrix)
		rightFillIndex: (self registerFill: aLine rightFill transform: aMatrix)
		matrix: aMatrix! !

!BalloonEngine methodsFor: 'experimental' stamp: 'ar 11/11/1998 21:15'!
subdivideExternalEdge: external from: boundaryObject
	| external2 |
	external2 _ external subdivide.
	external2 notNil ifTrue:[
		self subdivideExternalEdge: external from: boundaryObject.
		self subdivideExternalEdge: external2 from: boundaryObject.
	] ifFalse:[
		self registerExternalEdge: external from: boundaryObject.
	].! !


!BalloonEngine methodsFor: 'profiling' stamp: 'ar 11/11/1998 21:16'!
doAddCompressedShape: points segments: nSegments leftFills: leftFills rightFills: rightFills lineWidths: lineWidths lineFills: lineFills fillIndexList: fillIndexList matrix: aMatrix
	"Note: This method is for profiling the overhead of loading a compressed shape into the engine."
	^self primAddCompressedShape: points segments: nSegments leftFills: leftFills rightFills: rightFills lineWidths: lineWidths lineFills: lineFills fillIndexList: fillIndexList matrix: aMatrix! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BalloonEngine class
	instanceVariableNames: ''!

!BalloonEngine class methodsFor: 'class initialization' stamp: 'ar 11/11/1998 22:49'!
initialize
	"BalloonEngine initialize"
	BufferCache _ WeakArray new: 1.
	Smalltalk garbageCollect. "Make the cache old"
	CacheProtect _ Semaphore forMutualExclusion.
	Times _ WordArray new: 10.
	Counts _ WordArray new: 10.
	BezierStats _ WordArray new: 4.
	Debug ifNil:[Debug _ false].! !


!BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/25/1998 17:37'!
debug: aBoolean
	"BalloonEngine debug: true"
	"BalloonEngine debug: false"
	Debug _ aBoolean! !

!BalloonEngine class methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'!
doProfileStats: aBool
	"Note: On Macintosh systems turning on profiling can significantly
	degrade the performance of Balloon since we're using the high
	accuracy timer for measuring."
	"BalloonEngine doProfileStats: true"
	"BalloonEngine doProfileStats: false"
	<primitive: 'primitiveDoProfileStats' module: 'B2DPlugin'>
	^false! !

!BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/30/1998 23:57'!
printBezierStats
	"BalloonEngine printBezierStats"
	"BalloonEngine resetBezierStats"
	Transcript 
		cr; nextPutAll:'Bezier statistics:';
		crtab; print: (BezierStats at: 1); tab; nextPutAll:' non-monoton curves splitted';
		crtab; print: (BezierStats at: 2); tab; nextPutAll:' curves splitted for numerical accuracy';
		crtab; print: (BezierStats at: 3); tab; nextPutAll:' curves splitted to avoid integer overflow';
		crtab; print: (BezierStats at: 4); tab; nextPutAll:' curves internally converted to lines';
	endEntry.! !

!BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/28/1998 23:59'!
printStat: time count: n string: aString
	Transcript
		cr;
		print: time; tab;
		nextPutAll:' mSecs -- ';
		print: n; tab;
		nextPutAll:' ops -- ';
		print: ((time asFloat / (n max: 1) asFloat) roundTo: 0.01); tab;
		nextPutAll: ' avg. mSecs/op -- ';
		nextPutAll: aString.! !

!BalloonEngine class methodsFor: 'accessing' stamp: 'ar 1/12/1999 10:52'!
printStats
	"BalloonEngine doProfileStats: true"
	"BalloonEngine printStats"
	"BalloonEngine resetStats"
	Transcript cr; nextPutAll:'/************** BalloonEngine statistics ****************/'.
	self printStat: (Times at: 1) count: (Counts at: 1) string: 'Initialization'.
	self printStat: (Times at: 2) count: (Counts at: 2) string: 'Finish test'.
	self printStat: (Times at: 3) count: (Counts at: 3) string: 'Fetching/Adding GET entries'.
	self printStat: (Times at: 4) count: (Counts at: 4) string: 'Adding AET entries'.
	self printStat: (Times at: 5) count: (Counts at: 5) string: 'Fetching/Computing fills'.
	self printStat: (Times at: 6) count: (Counts at: 6) string: 'Merging fills'.
	self printStat: (Times at: 7) count: (Counts at: 7) string: 'Displaying span buffer'.
	self printStat: (Times at: 8) count: (Counts at: 8) string: 'Fetching/Updating AET entries'.
	self printStat: (Times at: 9) count: (Counts at: 9) string: 'Changing AET entries'.
	Transcript cr; print: Times sum; nextPutAll:' mSecs for all operations'.
	Transcript cr; print: Counts sum; nextPutAll: ' overall operations'.
	Transcript endEntry.! !

!BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/30/1998 23:57'!
resetBezierStats
	BezierStats _ WordArray new: 4.! !

!BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/28/1998 23:38'!
resetStats
	Times _ WordArray new: 10.
	Counts _ WordArray new: 10.! !


!BalloonEngine class methodsFor: 'private' stamp: 'ar 11/11/1998 22:50'!
allocateOrRecycleBuffer: initialSize
	"Try to recycly a buffer. If this is not possibly, create a new one."
	| buffer |
	CacheProtect critical:[
		buffer _ BufferCache at: 1.
		BufferCache at: 1 put: nil.
	].
	^buffer ifNil:[BalloonBuffer new: initialSize]! !

!BalloonEngine class methodsFor: 'private' stamp: 'ar 5/28/2000 22:17'!
primitiveSetBitBltPlugin: pluginName
	<primitive: 'primitiveSetBitBltPlugin' module: 'B2DPlugin'>
	^nil! !

!BalloonEngine class methodsFor: 'private' stamp: 'ar 11/11/1998 22:51'!
recycleBuffer: balloonBuffer
	"Try to keep the buffer for later drawing operations."
	| buffer |
	CacheProtect critical:[
		buffer _ BufferCache at: 1.
		(buffer isNil or:[buffer size < balloonBuffer size] )
			ifTrue:[BufferCache at: 1 put: balloonBuffer].
	].! !
SharedPool subclass: #BalloonEngineConstants
	instanceVariableNames: ''
	classVariableNames: 'BEAaLevelIndex BEBalloonEngineSize BEBitBltIndex BEClipRectIndex BEColorTransformIndex BEDeferredIndex BEDestOffsetIndex BEEdgeTransformIndex BEExternalsIndex BEFormsIndex BEPostFlushNeededIndex BESpanIndex BEWorkBufferIndex ETBalloonEdgeDataSize ETIndexIndex ETLinesIndex ETSourceIndex ETXValueIndex ETYValueIndex ETZValueIndex FTBalloonFillDataSize FTDestFormIndex FTIndexIndex FTMaxXIndex FTMinXIndex FTSourceIndex FTYValueIndex GBBaseSize GBBitmapDepth GBBitmapHeight GBBitmapRaster GBBitmapSize GBBitmapWidth GBColormapOffset GBColormapSize GBEndX GBEndY GBFinalX GBMBaseSize GBTileFlag GBUpdateData GBUpdateDDX GBUpdateDDY GBUpdateDX GBUpdateDY GBUpdateX GBUpdateY GBViaX GBViaY GBWideEntry GBWideExit GBWideExtent GBWideFill GBWideSize GBWideUpdateData GBWideWidth GEBaseEdgeSize GEBaseFillSize GEEdgeClipFlag GEEdgeFillsInvalid GEFillIndexLeft GEFillIndexRight GENumLines GEObjectIndex GEObjectLength GEObjectType GEObjectUnused GEPrimitiveBezier GEPrimitiveClippedBitmapFill GEPrimitiveEdge GEPrimitiveEdgeMask GEPrimitiveFill GEPrimitiveFillMask GEPrimitiveLine GEPrimitiveLinearGradientFill GEPrimitiveRadialGradientFill GEPrimitiveRepeatedBitmapFill GEPrimitiveTypeMask GEPrimitiveUnknown GEPrimitiveWide GEPrimitiveWideBezier GEPrimitiveWideEdge GEPrimitiveWideLine GEPrimitiveWideMask GErrorAETEntry GErrorBadState GErrorFillEntry GErrorGETEntry GErrorNeedFlush GErrorNoMoreSpace GEStateAddingFromGET GEStateBlitBuffer GEStateCompleted GEStateScanningAET GEStateUnlocked GEStateUpdateEdges GEStateWaitingChange GEStateWaitingForEdge GEStateWaitingForFill GEXValue GEYValue GEZValue GFDirectionX GFDirectionY GFNormalX GFNormalY GFOriginX GFOriginY GFRampLength GFRampOffset GGBaseSize GLBaseSize GLEndX GLEndY GLError GLErrorAdjDown GLErrorAdjUp GLWideEntry GLWideExit GLWideExtent GLWideFill GLWideSize GLWideWidth GLXDirection GLXIncrement GLYDirection GWAAColorMask GWAAColorShift GWAAHalfPixel GWAALevel GWAAScanMask GWAAShift GWAETStart GWAETUsed GWBezierHeightSubdivisions GWBezierLineConversions GWBezierMonotonSubdivisions GWBezierOverflowSubdivisions GWBufferTop GWClearSpanBuffer GWClipMaxX GWClipMaxY GWClipMinX GWClipMinY GWColorTransform GWCountAddAETEntry GWCountChangeAETEntry GWCountDisplaySpan GWCountFinishTest GWCountInitializing GWCountMergeFill GWCountNextAETEntry GWCountNextFillEntry GWCountNextGETEntry GWCurrentY GWCurrentZ GWDestOffsetX GWDestOffsetY GWEdgeTransform GWFillMaxX GWFillMaxY GWFillMinX GWFillMinY GWFillOffsetX GWFillOffsetY GWGETStart GWGETUsed GWHasClipShapes GWHasColorTransform GWHasEdgeTransform GWHeaderSize GWLastExportedEdge GWLastExportedFill GWLastExportedLeftX GWLastExportedRightX GWMagicIndex GWMagicNumber GWMinimalSize GWNeedsFlush GWObjStart GWObjUsed GWPoint1 GWPoint2 GWPoint3 GWPoint4 GWPointListFirst GWSize GWSpanEnd GWSpanEndAA GWSpanSize GWSpanStart GWState GWStopReason GWTimeAddAETEntry GWTimeChangeAETEntry GWTimeDisplaySpan GWTimeFinishTest GWTimeInitializing GWTimeMergeFill GWTimeNextAETEntry GWTimeNextFillEntry GWTimeNextGETEntry'
	poolDictionaries: ''
	category: 'Balloon-Engine'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BalloonEngineConstants class
	instanceVariableNames: ''!

!BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 19:55'!
initEdgeConstants
	"Initialize the edge constants"

	"Edge primitive types"
	GEPrimitiveEdge := 2.			"External edge - not handled by the GE"
	GEPrimitiveWideEdge := 3.		"Wide external edge"
	GEPrimitiveLine := 4.			"Straight line"
	GEPrimitiveWideLine := 5.		"Wide line"
	GEPrimitiveBezier := 6.		"Quadratic bezier curve"
	GEPrimitiveWideBezier := 7.	"Wide bezier curve"

	"Special flags"
	GEPrimitiveWide := 16r01.		"Flag determining a wide primitive"
	GEPrimitiveWideMask := 16rFE.	"Mask for clearing the wide flag"
	GEEdgeFillsInvalid := 16r10000. "Flag determining if left/right fills of an edge are invalid"
	GEEdgeClipFlag := 16r20000.	"Flag determining if this is a clip edge"

	"General edge state constants"
	GEXValue := 4.					"Current raster x"
	GEYValue := 5.					"Current raster y"
	GEZValue := 6.					"Current raster z"
	GENumLines := 7.					"Number of scan lines remaining"
	GEFillIndexLeft := 8.				"Left fill index"
	GEFillIndexRight := 9.				"Right fill index"
	GEBaseEdgeSize := 10.				"Basic size of each edge"

	"General fill state constants"
	GEBaseFillSize := 4.				"Basic size of each fill"

	"General Line state constants"
	GLXDirection := 10.				"Direction of edge (1: left-to-right; -1: right-to-left)"
	GLYDirection := 11.				"Direction of edge (1: top-to-bottom; -1: bottom-to-top)"
	GLXIncrement := 12.				"Increment at each scan line"
	GLError := 13.						"Current error"
	GLErrorAdjUp := 14.				"Error to add at each scan line"
	GLErrorAdjDown := 15.				"Error to subtract on roll-over"
			"Note: The following entries are only needed before the incremental
			state is computed. They are therefore aliased to the error values above"
	GLEndX := 14.						"End X of line"
	GLEndY := 15.						"End Y of line"
	GLBaseSize := 16.					"Basic size of each line"

	"Additional stuff for wide lines"
	GLWideFill := 16.					"Current fill of line"
	GLWideWidth := 17.				"Current width of line"
	GLWideEntry := 18.				"Initial steps"
	GLWideExit := 19.					"Final steps"
	GLWideExtent := 20.				"Target width"
	GLWideSize := 21.					"Size of wide lines"

	"General Bezier state constants"
	GBUpdateData := 10.				"Incremental update data for beziers"
	GBUpdateX := 0.				"Last computed X value (24.8)"
	GBUpdateY := 1.				"Last computed Y value (24.8)"
	GBUpdateDX := 2.				"Delta X forward difference step (8.24)"
	GBUpdateDY := 3.				"Delta Y forward difference step (8.24)"
	GBUpdateDDX := 4.				"Delta DX forward difference step (8.24)"
	GBUpdateDDY := 5.				"Delta DY forward difference step (8.24)"
		"Note: The following four entries are only needed before the incremental
			state is computed. They are therefore aliased to the incremental values above"
	GBViaX := 12.						"via x"
	GBViaY := 13.						"via y"
	GBEndX := 14.						"end x"
	GBEndY := 15.						"end y"
	GBBaseSize := 16.					"Basic size of each bezier.
										Note: MUST be greater or equal to the size of lines"
	"Additional stuff for wide beziers"
	GBWideFill := 16.					"Current fill of line"
	GBWideWidth := 17.				"Current width of line"
	GBWideEntry := 18.				"Initial steps"
	GBWideExit := 19.					"Final steps"
	GBWideExtent := 20.				"Target extent"
	GBFinalX := 21.					"Final X value"
	GBWideUpdateData := 22.	"Update data for second curve"
	GBWideSize := 28.					"Size of wide beziers"

! !

!BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:08'!
initFillConstants
	"Initialize the fill constants"

	"Fill primitive types"
	GEPrimitiveFill := 16r100.
	GEPrimitiveLinearGradientFill := 16r200.
	GEPrimitiveRadialGradientFill := 16r300.
	GEPrimitiveClippedBitmapFill := 16r400.
	GEPrimitiveRepeatedBitmapFill := 16r500.

	"General fill state constants"
	GEBaseFillSize := 4.				"Basic size of each fill"

	"Oriented fill constants"
	GFOriginX := 4.				"X origin of fill"
	GFOriginY := 5.				"Y origin of fill"
	GFDirectionX := 6.				"X direction of fill"
	GFDirectionY := 7.				"Y direction of fill"
	GFNormalX := 8.				"X normal of fill"
	GFNormalY := 9.				"Y normal of fill"

	"Gradient fill constants"
	GFRampLength := 10.			"Length of following color ramp"
	GFRampOffset := 12.			"Offset of first ramp entry"
	GGBaseSize := 12.

	"Bitmap fill constants"
	GBBitmapWidth := 10.			"Width of bitmap"
	GBBitmapHeight := 11.			"Height of bitmap"
	GBBitmapDepth := 12.			"Depth of bitmap"
	GBBitmapSize := 13.			"Size of bitmap words"
	GBBitmapRaster := 14.			"Size of raster line"
	GBColormapSize := 15.			"Size of colormap, if any"
	GBTileFlag := 16.				"True if the bitmap is tiled"
	GBColormapOffset := 18.		"Offset of colormap, if any"
	GBMBaseSize := 18.			"Basic size of bitmap fill"
! !

!BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 19:59'!
initPrimitiveConstants
	"Initialize the primitive constants"

	"Primitive type constants"
	GEPrimitiveUnknown := 0.
	GEPrimitiveEdgeMask := 16rFF.
	GEPrimitiveFillMask := 16rFF00.
	GEPrimitiveTypeMask := 16rFFFF.

	"General state constants (Note: could be compressed later)"
	GEObjectType := 0.				"Type of object"
	GEObjectLength := 1.			"Length of object"
	GEObjectIndex := 2.			"Index into external objects"
	GEObjectUnused := 3.			"Currently unused"

! !

!BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:00'!
initStateConstants
	"Initialize the state Constants"

	GEStateUnlocked := 0.			"Buffer is unlocked and can be modified as wanted"
	GEStateAddingFromGET := 1.	"Adding edges from the GET"
	GEStateWaitingForEdge := 2.	"Waiting for edges added to GET"
	GEStateScanningAET := 3.		"Scanning the active edge table"
	GEStateWaitingForFill := 4.		"Waiting for a fill to mix in during AET scan"
	GEStateBlitBuffer := 5.			"Blt the current scan line"
	GEStateUpdateEdges := 6.		"Update edges to next scan line"
	GEStateWaitingChange := 7.	"Waiting for a changed edge"
	GEStateCompleted := 8.			"Rendering completed"

	"Error constants"
	GErrorNoMoreSpace := 1.		"No more space in collection"
	GErrorBadState := 2.			"Tried to call a primitive while engine in bad state"
	GErrorNeedFlush := 3.			"Tried to call a primitive that requires flushing before"

	"Incremental error constants"
	GErrorGETEntry := 4.			"Unknown entry in GET"
	GErrorFillEntry := 5.			"Unknown FILL encountered"
	GErrorAETEntry := 6.			"Unknown entry in AET"
! !

!BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:04'!
initWorkBufferConstants
	"Initialize the work buffer constants"

	"General work buffer constants"
	GWMagicNumber := 16r416E6469.	"Magic number"
	GWHeaderSize := 128.				"Size of header"
	GWMinimalSize := 256.				"Minimal size of work buffer"

	"Header entries"
	GWMagicIndex := 0.				"Index of magic number"
	GWSize := 1.						"Size of full buffer"
	GWState := 2.						"Current state (e.g., locked or not."
	"Buffer entries"
	GWObjStart := 8.					"objStart"
	GWObjUsed := 9.					"objUsed"
	GWBufferTop := 10.				"wbTop"
	GWGETStart := 11.					"getStart"
	GWGETUsed := 12.					"getUsed"
	GWAETStart := 13.					"aetStart"
	GWAETUsed := 14.					"aetUsed"

	"Transform entries"
	GWHasEdgeTransform := 16.		"True if we have an edge transformation"
	GWHasColorTransform := 17.		"True if we have a color transformation"
	GWEdgeTransform := 18.			"2x3 edge transformation"
	GWColorTransform := 24.			"8 word RGBA color transformation"

	"Span entries"
	GWSpanStart := 32.				"spStart"
	GWSpanSize := 33.					"spSize"
	GWSpanEnd := 34.					"spEnd"
	GWSpanEndAA := 35.				"spEndAA"

	"Bounds entries"
	GWFillMinX := 36.					"fillMinX"
	GWFillMaxX := 37.					"fillMaxX"
	GWFillMinY := 38.					"fillMinY"
	GWFillMaxY := 39.					"fillMaxY"
	GWFillOffsetX := 40.				"fillOffsetX"
	GWFillOffsetY := 41.				"fillOffsetY"
	GWClipMinX := 42.
	GWClipMaxX := 43.
	GWClipMinY := 44.
	GWClipMaxY := 45.
	GWDestOffsetX := 46.
	GWDestOffsetY := 47.

	"AA entries"
	GWAALevel := 48.					"aaLevel"
	GWAAShift := 49.					"aaShift"
	GWAAColorShift := 50.				"aaColorShift"
	GWAAColorMask := 51.				"aaColorMask"
	GWAAScanMask := 52.				"aaScanMask"
	GWAAHalfPixel := 53.				"aaHalfPixel"

	"Misc entries"
	GWNeedsFlush := 63.				"True if the engine may need a flush"
	GWStopReason := 64.				"stopReason"
	GWLastExportedEdge := 65.			"last exported edge"
	GWLastExportedFill := 66.			"last exported fill"
	GWLastExportedLeftX := 67.			"last exported leftX"
	GWLastExportedRightX := 68.		"last exported rightX"
	GWClearSpanBuffer := 69.			"Do we have to clear the span buffer?"
	GWPointListFirst := 70.				"First point list in buffer"

	GWPoint1 := 80.
	GWPoint2 := 82.
	GWPoint3 := 84.
	GWPoint4 := 86.

	GWCurrentY := 88.

	"Profile stats"
	GWTimeInitializing := 90.
	GWCountInitializing := 91.
	GWTimeFinishTest := 92.
	GWCountFinishTest := 93.
	GWTimeNextGETEntry := 94.
	GWCountNextGETEntry := 95.
	GWTimeAddAETEntry := 96.
	GWCountAddAETEntry := 97.
	GWTimeNextFillEntry := 98.
	GWCountNextFillEntry := 99.
	GWTimeMergeFill := 100.
	GWCountMergeFill := 101.
	GWTimeDisplaySpan := 102.
	GWCountDisplaySpan := 103.
	GWTimeNextAETEntry := 104.
	GWCountNextAETEntry := 105.
	GWTimeChangeAETEntry := 106.
	GWCountChangeAETEntry := 107.

	"Bezier stats"
	GWBezierMonotonSubdivisions := 108. 	"# of subdivision due to non-monoton beziers"
	GWBezierHeightSubdivisions := 109.		"# of subdivisions due to excessive height"
	GWBezierOverflowSubdivisions := 110.	"# of subdivisions due to possible int overflow"
	GWBezierLineConversions := 111.		"# of beziers converted to lines"

	GWHasClipShapes := 112.		"True if the engine contains clip shapes"
	GWCurrentZ := 113.			"Current z value of primitives"
! !

!BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:08'!
initialize
	"BalloonEngineConstants initialize"
	self initStateConstants.
	self initWorkBufferConstants.
	self initPrimitiveConstants.
	self initEdgeConstants.
	self initFillConstants.
	self initializeInstVarNames: BalloonEngine prefixedBy: 'BE'.
	self initializeInstVarNames: BalloonEdgeData prefixedBy: 'ET'.
	self initializeInstVarNames: BalloonFillData prefixedBy: 'FT'.! !

!BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:07'!
initializeInstVarNames: aClass prefixedBy: aString

	| token value |
	aClass instVarNames doWithIndex:[:instVarName :index|
		token _ (aString, instVarName first asUppercase asString, (instVarName copyFrom: 2 to: instVarName size),'Index') asSymbol.
		value _ index - 1.
		(self bindingOf: token) ifNil:[self addClassVarName: token].
		(self bindingOf: token) value: value.
	].
	token _ (aString, aClass name,'Size') asSymbol.
	(self bindingOf: token) ifNil:[self addClassVarName: token].
	(self bindingOf: token) value: aClass instSize.! !
Object subclass: #BalloonFillData
	instanceVariableNames: 'index minX maxX yValue source destForm'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Simulation'!
!BalloonFillData commentStamp: '<historical>' prior: 0!
This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.!


!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:56'!
destForm
	^destForm! !

!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:56'!
destForm: aForm
	destForm _ aForm! !

!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'!
index
	^index! !

!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'!
index: anInteger
	index _ anInteger! !

!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'!
maxX
	^maxX! !

!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'!
maxX: anInteger
	maxX _ anInteger! !

!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'!
minX
	^minX! !

!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'!
minX: anInteger
	minX _ anInteger! !

!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:56'!
source
	^source! !

!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:56'!
source: anObject
	source _ anObject! !

!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/28/1998 16:35'!
width
	^maxX - minX! !

!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'!
yValue
	^yValue! !

!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'!
yValue: anInteger
	yValue _ anInteger! !


!BalloonFillData methodsFor: 'computing' stamp: 'ar 11/14/1998 19:32'!
computeFill
	(destForm isNil or:[destForm width < self width]) ifTrue:[
		destForm _ Form extent: (self width + 10) @ 1 depth: 32.
	].
	source computeFillFrom: minX to: maxX at: yValue in: destForm! !
TestCase subclass: #BalloonFontTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets-Tests'!

!BalloonFontTest methodsFor: 'testing' stamp: 'sd 12/9/2001 21:44'!
testDefaultFont
	"(self selector: #testDefaultFont) debug"
	self assert: RectangleMorph new balloonFont = BalloonMorph balloonFont.
	self assert: RectangleMorph new defaultBalloonFont = BalloonMorph balloonFont.! !

!BalloonFontTest methodsFor: 'testing' stamp: 'sd 12/9/2001 21:55'!
testSpecificFont
	"(self selector: #testSpecificFont) debug"
	| aMorph |
	aMorph := RectangleMorph new.
	self assert: RectangleMorph new balloonFont = BalloonMorph balloonFont.
	self assert: RectangleMorph new defaultBalloonFont = BalloonMorph balloonFont.
	aMorph
		balloonFont: (StrikeFont familyName: #ComicPlain size: 19).
	self assert: aMorph balloonFont
			= (StrikeFont familyName: #ComicPlain size: 19).
	"The next test is horrible because I do no know how to access the font 
	with the appropiate interface"
	self assert: (((BalloonMorph getTextMorph: 'lulu' for: aMorph) text runs at: 1)
			at: 1) font
			= (StrikeFont familyName: #ComicPlain size: 19)! !
Object subclass: #BalloonLineSimulation
	instanceVariableNames: 'start end xIncrement xDirection error errorAdjUp errorAdjDown'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Simulation'!
!BalloonLineSimulation commentStamp: '<historical>' prior: 0!
This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.!


!BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 03:02'!
end
	^end! !

!BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 03:02'!
end: aPoint
	end _ aPoint! !

!BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:31'!
initialX
	^start y <= end y
		ifTrue:[start x]
		ifFalse:[end x]! !

!BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:31'!
initialY
	^start y <= end y
		ifTrue:[start y]
		ifFalse:[end y]! !

!BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:31'!
initialZ
	^0 "Assume no depth given"! !

!BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 03:02'!
start
	^start! !

!BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 03:02'!
start: aPoint
	start _ aPoint! !


!BalloonLineSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 20:52'!
computeInitialStateFrom: source with: aTransformation
	"Compute the initial state in the receiver."
	start _ (aTransformation localPointToGlobal: source start) asIntegerPoint.
	end _ (aTransformation localPointToGlobal: source end) asIntegerPoint.! !

!BalloonLineSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 23:22'!
stepToFirstScanLineAt: yValue in: edgeTableEntry
	"Compute the initial x value for the scan line at yValue"
	|  startX endX startY endY yDir deltaY deltaX widthX |
	(start y) <= (end y) ifTrue:[
		startX _ start x.	endX _ end x.
		startY _ start y.	endY _ end y.
		yDir _ 1.
	] ifFalse:[
		startX _ end x.	endX _ start x.
		startY _ end y.	endY _ start y.
		yDir _ -1.
	].

	deltaY _ endY - startY.
	deltaX _ endX - startX.

	"Quickly check if the line is visible at all"
	(yValue >= endY or:[deltaY = 0]) ifTrue:[^edgeTableEntry lines: 0].

	"Check if edge goes left to right"
	deltaX >= 0 ifTrue:[
		xDirection _ 1.
		widthX _ deltaX.
		error _ 0.
	] ifFalse:[
		xDirection _ -1.
		widthX _ 0 - deltaX.
		error _ 1 - deltaY.
	].

	"Check if edge is horizontal"
	deltaY = 0 
		ifTrue:[	xIncrement _ 0.
				errorAdjUp _ 0]
		ifFalse:["Check if edge is y-major"
			deltaY > widthX 
				ifTrue:[	xIncrement _ 0.
						errorAdjUp _ widthX]
				ifFalse:[	xIncrement _ (widthX // deltaY) * xDirection.
						errorAdjUp _ widthX \\ deltaY]].

	errorAdjDown _ deltaY.

	edgeTableEntry xValue: startX.
	edgeTableEntry lines: deltaY.

	"If not at first scan line then step down to yValue"
	yValue = startY ifFalse:[
		startY to: yValue do:[:y| self stepToNextScanLineAt: y in: edgeTableEntry].
		"And adjust remainingLines"
		edgeTableEntry lines: deltaY - (yValue - startY).
	].! !

!BalloonLineSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 20:39'!
stepToNextScanLineAt: yValue in: edgeTableEntry
	"Compute the next x value for the scan line at yValue.
	This message is sent during incremental updates. 
	The yValue parameter is passed in here for edges
	that have more complicated computations,"
	| x |
	x _ edgeTableEntry xValue + xIncrement.
	error _ error + errorAdjUp.
	error > 0 ifTrue:[
		x _ x + xDirection.
		error _ error - errorAdjDown.
	].
	edgeTableEntry xValue: x.! !

!BalloonLineSimulation methodsFor: 'computing' stamp: 'ar 10/29/1998 23:42'!
subdivide
	^nil! !


!BalloonLineSimulation methodsFor: 'printing' stamp: 'ar 10/27/1998 23:20'!
printOn: aStream
	aStream 
		nextPutAll: self class name;
		nextPut:$(;
		print: start;
		nextPutAll:' - ';
		print: end;
		nextPut:$)! !

!BalloonLineSimulation methodsFor: 'printing' stamp: 'MPW 1/1/1901 21:57'!
printOnStream: aStream
	aStream 
		print: self class name;
		print:'(';
		write: start;
		print:' - ';
		write: end;
		print:')'.! !
PolygonMorph subclass: #BalloonMorph
	instanceVariableNames: 'target offsetFromTarget balloonOwner'
	classVariableNames: 'BalloonColor BalloonFont'
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!BalloonMorph commentStamp: '<historical>' prior: 0!
A balloon with text used for the display of explanatory information.

Balloon help is integrated into Morphic as follows:
If a Morph has the property #balloonText, then it will respond to #showBalloon by adding a text balloon to the world, and to #deleteBalloon by removing the balloon.

Moreover, if mouseOverEnabled is true (see class msg), then the Hand will arrange to cause display of the balloon after the mouse has lingered over the morph for a while, and removal of the balloon when the mouse leaves the bounds of that morph.  In any case, the Hand will attempt to remove any such balloons before handling mouseDown events, or displaying other balloons.

Balloons should not be duplicated with veryDeepCopy unless their target is also duplicated at the same time.!


!BalloonMorph methodsFor: 'WiW support' stamp: 'RAA 6/27/2000 18:07'!
morphicLayerNumber

	"helpful for insuring some morphs always appear in front of or behind others.
	smaller numbers are in front"

	^5		"Balloons are very front-like things"! !


!BalloonMorph methodsFor: 'accessing' stamp: 'ar 10/3/2000 17:19'!
balloonOwner
	^balloonOwner! !


!BalloonMorph methodsFor: 'classification' stamp: 'ar 9/15/2000 17:56'!
isBalloonHelp
	^true! !


!BalloonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:33'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ Color black! !

!BalloonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 1! !

!BalloonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ self class balloonColor! !

!BalloonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:20'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self beSmoothCurve.

	offsetFromTarget _ 0 @ 0! !

!BalloonMorph methodsFor: 'initialization' stamp: 'ar 10/4/2000 10:13'!
popUpFor: aMorph hand: aHand
	"Pop up the receiver as balloon help for the given hand"
	balloonOwner _ aMorph.
	self popUpForHand: aHand.! !

!BalloonMorph methodsFor: 'initialization' stamp: 'RAA 7/1/2001 18:48'!
popUpForHand: aHand
	"Pop up the receiver as balloon help for the given hand"
	| worldBounds |

	self lock.
	self fullBounds. "force layout"
	self setProperty: #morphicLayerNumber toValue: self morphicLayerNumber.
	aHand world addMorphFront: self.
	"So that if the translation below makes it overlap the receiver, it won't
	interfere with the rootMorphsAt: logic and hence cause flashing.  Without
	this, flashing happens, believe me!!"
	((worldBounds _ aHand world bounds) containsRect: self bounds) ifFalse:
		[self bounds: (self bounds translatedToBeWithin: worldBounds)].
	aHand balloonHelp: self.
! !


!BalloonMorph methodsFor: 'menus' stamp: 'wiz 12/30/2004 17:14'!
adjustedCenter
	"Return the center of the original textMorph box within the balloon."

	^ (self vertices last: 4) average rounded  ! !


!BalloonMorph methodsFor: 'stepping and presenter' stamp: 'sma 12/23/1999 14:05'!
step
	"Move with target."

	target ifNotNil: [self position: target position + offsetFromTarget].
! !


!BalloonMorph methodsFor: 'testing' stamp: 'di 9/18/97 10:10'!
stepTime
	^ 0  "every cycle"! !


!BalloonMorph methodsFor: 'private' stamp: 'sma 12/23/1999 14:06'!
setTarget: aMorph
	(target _ aMorph) ifNotNil: [offsetFromTarget _ self position - target position]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BalloonMorph class
	instanceVariableNames: ''!

!BalloonMorph class methodsFor: 'instance creation' stamp: 'sma 12/23/1999 20:05'!
string: str for: morph
	^ self string: str for: morph corner: #bottomLeft! !

!BalloonMorph class methodsFor: 'instance creation' stamp: 'yo 11/13/2007 15:03'!
string: str for: morph corner: cornerName 

	^ self string: str for: morph corner: cornerName force: false.
! !

!BalloonMorph class methodsFor: 'instance creation' stamp: 'yo 11/13/2007 14:44'!
string: str for: morph corner: cornerName force: forceFlag
	"Make up and return a balloon for morph. Find the quadrant that 
	clips the text the least, using cornerName as a tie-breaker. tk 9/12/97"
	| tm vertices |
	tm _ self getTextMorph: str for: morph.
	vertices _ self getVertices: tm bounds.
	vertices _ self
				getBestLocation: vertices
				for: morph
				corner: cornerName
				force: forceFlag.
	^ self new color: morph balloonColor;
		 setVertices: vertices;
		 addMorph: tm;
		 setTarget: morph! !


!BalloonMorph class methodsFor: 'utility' stamp: 'sma 11/11/2000 14:59'!
balloonColor
	^ BalloonColor! !

!BalloonMorph class methodsFor: 'utility' stamp: 'sw 1/31/2000 15:43'!
balloonFont
	^ BalloonFont! !

!BalloonMorph class methodsFor: 'utility' stamp: 'nk 9/1/2004 10:47'!
chooseBalloonFont
	"BalloonMorph chooseBalloonFont"

	Preferences chooseFontWithPrompt:  'Select the font to be
used for balloon help' translated
		andSendTo: self withSelector: #setBalloonFontTo: highlight: BalloonFont! !

!BalloonMorph class methodsFor: 'utility' stamp: 'sma 11/11/2000 14:59'!
setBalloonColorTo: aColor 
	aColor ifNotNil: [BalloonColor _ aColor]! !

!BalloonMorph class methodsFor: 'utility' stamp: 'sw 1/31/2000 15:40'!
setBalloonFontTo: aFont
	aFont ifNotNil: [BalloonFont _ aFont]! !


!BalloonMorph class methodsFor: 'private' stamp: 'yo 11/13/2007 15:01'!
getBestLocation: vertices for: morph corner: cornerName

	^ self getBestLocation: vertices for: morph corner: cornerName force: false.
! !

!BalloonMorph class methodsFor: 'private' stamp: 'yo 11/13/2007 15:25'!
getBestLocation: vertices for: morph corner: cornerName force: forceFlag
	"Try four rel locations of the balloon for greatest unclipped area.   12/99 sma"

	| rect maxArea verts rectCorner morphPoint mbc a mp dir bestVerts result usableArea |
	rect _ vertices first rect: (vertices at: 5).
	maxArea _ -1.
	verts _ vertices.
	usableArea _ (morph world ifNil: [self currentWorld]) viewBox.
	1 to: 4 do: [:i |
		dir _ #(vertical horizontal) atWrap: i.
		verts _ verts collect: [:p | p flipBy: dir centerAt: rect center].
		rectCorner _ #(bottomLeft bottomRight topRight topLeft) at: i.
		morphPoint _ #(topCenter topCenter bottomCenter bottomCenter) at: i.
		a _ ((rect
			align: (rect perform: rectCorner)
			with: (mbc _ morph boundsForBalloon perform: morphPoint))
				intersect: usableArea) area.
		((forceFlag and: [rectCorner = cornerName]) or: [
			(a > maxArea or: [a = rect area and: [rectCorner = cornerName]])]) ifTrue:
			[maxArea _ a.
			bestVerts _ verts.
			mp _ mbc].
		(forceFlag and: [rectCorner = cornerName]) ifTrue: [
			^ bestVerts collect: [:p | p + (mp - bestVerts first)] "Inlined align:with:".
		]].
	result _ bestVerts collect: [:p | p + (mp - bestVerts first)] "Inlined align:with:".
	^ result! !

!BalloonMorph class methodsFor: 'private' stamp: 'sd 12/5/2001 20:28'!
getTextMorph: aStringOrMorph for: balloonOwner
	"Construct text morph."
	| m text |
	aStringOrMorph isMorph
		ifTrue: [m _ aStringOrMorph]
		ifFalse: [BalloonFont
				ifNil: [text _ aStringOrMorph]
				ifNotNil: [text _ Text
								string: aStringOrMorph
								attribute: (TextFontReference toFont: balloonOwner balloonFont)].
			m _ (TextMorph new contents: text) centered].
	m setToAdhereToEdge: #adjustedCenter.
	^ m! !

!BalloonMorph class methodsFor: 'private' stamp: 'sma 12/23/1999 15:34'!
getVertices: bounds
	"Construct vertices for a balloon up and to left of anchor"

	| corners |
	corners _ bounds corners atAll: #(1 4 3 2).
	^ (Array
		with: corners first + (0 - bounds width // 3 @ 0)
		with: corners first + (0 - bounds width // 6 @ (bounds height // 2))) , corners! !
RectangleMorph subclass: #BalloonRectangleMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Geometry'!
!BalloonRectangleMorph commentStamp: '<historical>' prior: 0!
BalloonRectangleMorph is an example for drawing using the BalloonEngine.!


!BalloonRectangleMorph methodsFor: 'accessing' stamp: 'ar 11/15/1998 22:24'!
doesBevels
	"To return true means that this object can show bevelled borders, and
	therefore can accept, eg, #raised or #inset as valid borderColors.
	Must be overridden by subclasses that do not support bevelled borders."

	^ false! !


!BalloonRectangleMorph methodsFor: 'drawing' stamp: 'ar 11/15/1998 22:40'!
drawOn: aCanvas
	(color isKindOf: OrientedFillStyle) ifTrue:[
		color origin: bounds center.
		color direction: (bounds extent x * 0.7) @ 0.
		color normal: 0@(bounds extent y * 0.7).
	].
	(borderColor isKindOf: OrientedFillStyle) ifTrue:[
		borderColor origin: bounds topLeft.
		borderColor direction: (bounds extent x) @ 0.
		borderColor normal: 0@(bounds extent y).
	].
	aCanvas asBalloonCanvas
		drawRectangle: (bounds insetBy: borderWidth // 2)
		color: color
		borderWidth: borderWidth
		borderColor: borderColor.! !


!BalloonRectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:33'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ GradientFillStyle ramp: {0.0 -> Color black. 1.0 -> Color white}! !

!BalloonRectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 10! !

!BalloonRectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'!
defaultColor
	"answer the default color/fill style for the receiver"
	| result |
	result _ GradientFillStyle ramp: {0.0 -> Color green. 0.5 -> Color yellow. 1.0 -> Color red}.
	result radial: true.
	^ result! !

!BalloonRectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:41'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	self extent: 100 @ 100! !


!BalloonRectangleMorph methodsFor: 'rotate scale and flex' stamp: 'ar 11/15/1998 22:20'!
newTransformationMorph
	^MatrixTransformMorph new! !


!BalloonRectangleMorph methodsFor: 'testing' stamp: 'ar 8/25/2001 19:08'!
canDrawBorder: aBorderStyle
	^aBorderStyle style == #simple! !
Object subclass: #BalloonSolidFillSimulation
	instanceVariableNames: 'color'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Simulation'!
!BalloonSolidFillSimulation commentStamp: '<historical>' prior: 0!
This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.!


!BalloonSolidFillSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 23:07'!
computeFillFrom: minX to: maxX at: yValue in: form
	| bb |
	color isTransparent ifFalse:[
		bb _ BitBlt toForm: form.
		bb fillColor: color.
		bb destX: 0 destY: 0 width: (maxX - minX) height: 1.
		bb combinationRule: Form over.
		bb copyBits].! !

!BalloonSolidFillSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 23:08'!
computeInitialStateFrom: source with: aColorTransform
	color _ source asColor.! !
Object subclass: #BalloonState
	instanceVariableNames: 'transform colorTransform aaLevel'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Engine'!
!BalloonState commentStamp: '<historical>' prior: 0!
This class is a repository for data which needs to be preserved during certain operations of BalloonCanvas.!


!BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:47'!
aaLevel
	^aaLevel! !

!BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:47'!
aaLevel: aNumber
	aaLevel _ aNumber! !

!BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:42'!
colorTransform
	^colorTransform! !

!BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:42'!
colorTransform: aColorTransform
	colorTransform _ aColorTransform! !

!BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:41'!
transform
	^transform! !

!BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:42'!
transform: aMatrixTransform
	transform _ aMatrixTransform! !
MimeConverter subclass: #Base64MimeConverter
	instanceVariableNames: 'data'
	classVariableNames: 'FromCharTable ToCharTable'
	poolDictionaries: ''
	category: 'Collections-Streams'!
!Base64MimeConverter commentStamp: '<historical>' prior: 0!
This class encodes and decodes data in Base64 format.  This is MIME encoding.  We translate a whole stream at once, taking a Stream as input and giving one as output.  Returns a whole stream for the caller to use.
           0 A            17 R            34 i            51 z
           1 B            18 S            35 j            52 0
           2 C            19 T            36 k            53 1
           3 D            20 U            37 l            54 2
           4 E            21 V            38 m            55 3
           5 F            22 W            39 n            56 4
           6 G            23 X            40 o            57 5
           7 H            24 Y            41 p            58 6
           8 I            25 Z            42 q            59 7
           9 J            26 a            43 r            60 8
          10 K            27 b            44 s            61 9
          11 L            28 c            45 t            62 +
          12 M            29 d            46 u            63 /
          13 N            30 e            47 v
          14 O            31 f            48 w         (pad) =
          15 P            32 g            49 x
          16 Q            33 h            50 y
Outbound: bytes are broken into 6 bit chunks, and the 0-63 value is converted to a character.  3 data bytes go into 4 characters.
Inbound: Characters are translated in to 0-63 values and shifted into 8 bit bytes.

(See: N. Borenstein, Bellcore, N. Freed, Innosoft, Network Working Group, Request for Comments: RFC 1521, September 1993, MIME (Multipurpose Internet Mail Extensions) Part One: Mechanisms for Specifying and Describing the Format of Internet Message Bodies. Sec 6.2)

By Ted Kaehler, based on Tim Olson's Base64Filter.!


!Base64MimeConverter methodsFor: 'conversion' stamp: 'tk 12/9/97 13:34'!
mimeDecode
	"Convert a stream in base 64 with only a-z,A-Z,0-9,+,/ to a full byte stream of characters.  Reutrn a whole stream for the user to read."

	| nibA nibB nibC nibD |
	[mimeStream atEnd] whileFalse: [
		(nibA _ self nextValue) ifNil: [^ dataStream].
		(nibB _ self nextValue) ifNil: [^ dataStream].
		dataStream nextPut: ((nibA bitShift: 2) + (nibB bitShift: -4)) asCharacter.
		nibB _ nibB bitAnd: 16rF.
		(nibC _ self nextValue) ifNil: [^ dataStream].
		dataStream nextPut: ((nibB bitShift: 4) + (nibC bitShift: -2)) asCharacter.
		nibC _ nibC bitAnd: 16r3.
		(nibD _ self nextValue) ifNil: [^ dataStream].
		dataStream nextPut: ((nibC bitShift: 6) + nibD) asCharacter.
		].
	^ dataStream! !

!Base64MimeConverter methodsFor: 'conversion' stamp: 'tk 12/9/97 13:39'!
mimeDecodeToByteArray
	"Convert a stream in base 64 with only a-z,A-Z,0-9,+,/ to a full ByteArray of 0-255 values.  Reutrn a whole stream for the user to read."

	| nibA nibB nibC nibD |
	[mimeStream atEnd] whileFalse: [
		(nibA _ self nextValue) ifNil: [^ dataStream].
		(nibB _ self nextValue) ifNil: [^ dataStream].
		dataStream nextPut: ((nibA bitShift: 2) + (nibB bitShift: -4)).
		nibB _ nibB bitAnd: 16rF.
		(nibC _ self nextValue) ifNil: [^ dataStream].
		dataStream nextPut: ((nibB bitShift: 4) + (nibC bitShift: -2)).
		nibC _ nibC bitAnd: 16r3.
		(nibD _ self nextValue) ifNil: [^ dataStream].
		dataStream nextPut: ((nibC bitShift: 6) + nibD).
		].
	^ dataStream! !

!Base64MimeConverter methodsFor: 'conversion' stamp: 'ls 2/10/2001 13:26'!
mimeEncode
	"Convert from data to 6 bit characters."

	| phase1 phase2 raw nib lineLength |
	phase1 _ phase2 _ false.
	lineLength := 0.
	[dataStream atEnd] whileFalse: [
		lineLength >= 70 ifTrue: [ mimeStream cr.  lineLength := 0. ].
		data _ raw _ dataStream next asInteger.
		nib _ (data bitAnd: 16rFC) bitShift: -2.
		mimeStream nextPut: (ToCharTable at: nib+1).
		(raw _ dataStream next) ifNil: [raw _ 0. phase1 _ true].
		data _ ((data bitAnd: 3) bitShift: 8) + raw asInteger.
		nib _ (data bitAnd: 16r3F0) bitShift: -4.
		mimeStream nextPut: (ToCharTable at: nib+1).
		(raw _ dataStream next) ifNil: [raw _ 0. phase2 _ true].
		data _ ((data bitAnd: 16rF) bitShift: 8) + (raw asInteger).
		nib _ (data bitAnd: 16rFC0) bitShift: -6.
		mimeStream nextPut: (ToCharTable at: nib+1).
		nib _ (data bitAnd: 16r3F).
		mimeStream nextPut: (ToCharTable at: nib+1).

		lineLength := lineLength + 4.].
	phase1 ifTrue: [mimeStream skip: -2; nextPut: $=; nextPut: $=.
			^ mimeStream].
	phase2 ifTrue: [mimeStream skip: -1; nextPut: $=.
			^ mimeStream].

! !

!Base64MimeConverter methodsFor: 'conversion' stamp: 'tk 12/9/97 13:21'!
nextValue
	"The next six bits of data char from the mimeStream, or nil.  Skip all other chars"
	| raw num |
	[raw _ mimeStream next.
	raw ifNil: [^ nil].	"end of stream"
	raw == $= ifTrue: [^ nil].
	num _ FromCharTable at: raw asciiValue + 1.
	num ifNotNil: [^ num].
	"else ignore space, return, tab, ..."
	true] whileTrue.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Base64MimeConverter class
	instanceVariableNames: ''!

!Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 2/19/2000 15:53'!
decodeInteger: mimeString
	| bytes sum |
	"Decode the MIME string into an integer of any length"

	bytes _ (Base64MimeConverter mimeDecodeToBytes: 
				(ReadStream on: mimeString)) contents.
	sum _ 0.
	bytes reverseDo: [:by | sum _ sum * 256 + by].
	^ sum! !

!Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 2/21/2000 17:22'!
encodeInteger: int
	| strm |
	"Encode an integer of any length and return the MIME string"

	strm _ ReadWriteStream on: (ByteArray new: int digitLength).
	1 to: int digitLength do: [:ii | strm nextPut: (int digitAt: ii)].
	strm reset.
	^ ((self mimeEncode: strm) contents) copyUpTo: $=	"remove padding"! !

!Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/9/97 13:53'!
initialize

	FromCharTable _ Array new: 256.	"nils"
	ToCharTable _ Array new: 64.
	($A asciiValue to: $Z asciiValue) doWithIndex: [:val :ind | 
		FromCharTable at: val+1 put: ind-1.
		ToCharTable at: ind put: val asCharacter].
	($a asciiValue to: $z asciiValue) doWithIndex: [:val :ind | 
		FromCharTable at: val+1 put: ind+25.
		ToCharTable at: ind+26 put: val asCharacter].
	($0 asciiValue to: $9 asciiValue) doWithIndex: [:val :ind | 
		FromCharTable at: val+1 put: ind+25+26.
		ToCharTable at: ind+26+26 put: val asCharacter].
	FromCharTable at: $+ asciiValue + 1 put: 62.
	ToCharTable at: 63 put: $+.
	FromCharTable at: $/ asciiValue + 1 put: 63.
	ToCharTable at: 64 put: $/.
	! !

!Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/12/97 11:41'!
mimeDecodeToBytes: aStream 
	"Return a RWBinaryOrTextStream of the original ByteArray.  aStream has only 65 innocuous character values.  aStream is not binary.  (See class comment). 4 bytes in aStream goes to 3 bytes in output."

	| me |
	aStream position: 0.
	me _ self new mimeStream: aStream.
	me dataStream: (RWBinaryOrTextStream on: (ByteArray new: aStream size * 3 // 4)).
	me mimeDecodeToByteArray.
	me dataStream position: 0.
	^ me dataStream! !

!Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/9/97 13:01'!
mimeDecodeToChars: aStream 
	"Return a ReadWriteStream of the original String.  aStream has only 65 innocuous character values.  It is not binary.  (See class comment). 4 bytes in aStream goes to 3 bytes in output."

	| me |
	aStream position: 0.
	me _ self new mimeStream: aStream.
	me dataStream: (ReadWriteStream on: (String new: aStream size * 3 // 4)).
	me mimeDecode.
	me dataStream position: 0.
	^ me dataStream! !

!Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/9/97 12:28'!
mimeEncode: aStream
	"Return a ReadWriteStream of characters.  The data of aStream is encoded as 65 innocuous characters.  (See class comment). 3 bytes in aStream goes to 4 bytes in output."

	| me |
	aStream position: 0.
	me _ self new dataStream: aStream.
	me mimeStream: (ReadWriteStream on: (String new: aStream size + 20 * 4 // 3)).
	me mimeEncode.
	me mimeStream position: 0.
	^ me mimeStream! !
TestCase subclass: #Base64MimeConverterTest
	instanceVariableNames: 'message'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams-Tests'!
!Base64MimeConverterTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class Base64MimeConverter. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 
	- http://www.c2.com/cgi/wiki?UnitTest
	- http://minnow.cc.gatech.edu/squeak/1547
	- the sunit class category!


!Base64MimeConverterTest methodsFor: 'initialize-release' stamp: 'md 3/17/2003 15:37'!
setUp
	message _ ReadWriteStream on: (String new: 10).
	message nextPutAll: 'Hi There!!'.! !

!Base64MimeConverterTest methodsFor: 'initialize-release' stamp: 'md 3/17/2003 15:34'!
tearDown
	"I am called whenever your test ends. 
I am the place where you release the ressources"! !

!Base64MimeConverterTest methodsFor: 'initialize-release' stamp: 'md 3/17/2003 15:45'!
testMimeEncodeDecode

	| encoded |

	encoded _ Base64MimeConverter mimeEncode: message.
	
	self should: [encoded contents = 'SGkgVGhlcmUh'].
     self should: [(Base64MimeConverter mimeDecodeToChars: encoded)
                      contents = message contents].! !
AbstractSoundSystem subclass: #BaseSoundSystem
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!BaseSoundSystem commentStamp: 'gk 2/24/2004 08:35' prior: 0!
This is the normal sound system in Squeak and is registered in SoundService - an AppRegistry - so that a small highlevel protocol for playing sounds can be used in a pluggable fashion.

More information available in superclass.!


!BaseSoundSystem methodsFor: 'misc' stamp: 'gk 2/24/2004 23:13'!
randomBitsFromSoundInput: bitCount
	"Answer a positive integer with the given number of random bits of 'noise' from a sound input source. Typically, one would use a microphone or line input as the sound source, although many sound cards have enough thermal noise that you get random low-order sample bits even with no microphone connected. Only the least signficant bit of the samples is used. Since not all sound cards support 16-bits of sample resolution, we use the lowest bit that changes."
	"(1 to: 10) collect: [:i | BaseSoundSystem new randomBitsFromSoundInput: 512]"

	| recorder buf mid samples bitMask randomBits bit |
	"collect some sound data"
	recorder _ SoundRecorder new clearRecordedSound.
	recorder resumeRecording.
	(Delay forSeconds: 1) wait.
	recorder stopRecording.
	buf _ recorder condensedSamples.

	"grab bitCount samples from the middle"
	mid _ buf monoSampleCount // 2.
	samples _ buf copyFrom: mid to: mid + bitCount - 1.

	"find the least significant bit that varies"
	bitMask _ 1.
	[bitMask < 16r10000 and:
	 [(samples collect: [:s | s bitAnd: bitMask]) asSet size < 2]]
		whileTrue: [bitMask _ bitMask bitShift: 1].
	bitMask = 16r10000 ifTrue: [^ self error: 'sound samples do not vary'].

	"pack the random bits into a positive integer"
	randomBits _ 0.
	1 to: samples size do: [:i |
		bit _ ((samples at: i) bitAnd: bitMask) = 0 ifTrue: [0] ifFalse: [1].
		randomBits _ (randomBits bitShift: 1) + bit].

	^ randomBits	
! !

!BaseSoundSystem methodsFor: 'misc' stamp: 'ads 7/30/2003 22:18'!
sampledSoundChoices
	^ SampledSound soundNames! !

!BaseSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:53'!
shutDown
	SoundPlayer shutDown
! !

!BaseSoundSystem methodsFor: 'misc' stamp: 'ads 7/30/2003 23:17'!
soundNamed: soundName
	^ SampledSound soundNamed: soundName! !


!BaseSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:20'!
beep
	"There is sound support, so we use the default
	sampled sound for a beep."

	Preferences soundsEnabled ifTrue: [
		SampledSound beep]! !

!BaseSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:20'!
playSampledSound: samples rate: rate

	Preferences soundsEnabled ifTrue: [
		(SampledSound samples: samples samplingRate: rate) play]! !

!BaseSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:23'!
playSoundNamed: soundName
	"There is sound support, so we play the given sound."

	Preferences soundsEnabled ifTrue: [
		SampledSound playSoundNamed: soundName asString]! !

!BaseSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:22'!
playSoundNamed: soundName ifAbsentReadFrom: aifFileName

	Preferences soundsEnabled ifTrue: [
		(SampledSound soundNames includes: soundName) ifFalse: [
			(FileDirectory default fileExists: aifFileName) ifTrue: [
				SampledSound
					addLibrarySoundNamed: soundName
					fromAIFFfileNamed: aifFileName]].
		(SampledSound soundNames includes: soundName) ifTrue: [
			SampledSound playSoundNamed: soundName]]! !

!BaseSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:23'!
playSoundNamedOrBeep: soundName
	"There is sound support, so we play the given sound
	instead of beeping."

	Preferences soundsEnabled ifTrue: [
		^self playSoundNamed: soundName]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BaseSoundSystem class
	instanceVariableNames: ''!

!BaseSoundSystem class methodsFor: 'class initialization' stamp: 'gk 2/23/2004 21:08'!
initialize
	SoundService register: self new.! !

!BaseSoundSystem class methodsFor: 'class initialization' stamp: 'gk 2/23/2004 21:08'!
unload
	SoundService registeredClasses do: [:ss |
		(ss isKindOf: self) ifTrue: [SoundService unregister: ss]].! !
RectangleMorph subclass: #BasicButton
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting'!
!BasicButton commentStamp: '<historical>' prior: 0!
A minimalist button-like object intended for use with the tile-scripting system.!


!BasicButton methodsFor: 'as yet unclassified' stamp: 'sw 6/16/1998 16:49'!
label
	| s |
	s _ ''.
	self allMorphsDo: [:m | (m isKindOf: StringMorph) ifTrue: [s _ m contents]].
	^ s! !

!BasicButton methodsFor: 'as yet unclassified' stamp: 'sw 12/7/1999 18:14'!
label: aString

	| oldLabel m |
	(oldLabel _ self findA: StringMorph)
		ifNotNil: [oldLabel delete].
	m _ StringMorph contents: aString font: TextStyle defaultFont.
	self extent: m extent + (borderWidth + 6).
	m position: self center - (m extent // 2).
	self addMorph: m.
	m lock! !

!BasicButton methodsFor: 'as yet unclassified' stamp: 'sw 12/10/1999 09:08'!
setLabel
	| newLabel |
	newLabel _ FillInTheBlank
		request:
'Enter a new label for this button'
		initialAnswer: self label.
	newLabel isEmpty ifFalse: [self label: newLabel font: nil].
! !


!BasicButton methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:33'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ Color yellow darker! !

!BasicButton methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 1! !

!BasicButton methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color yellow! !

!BasicButton methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:52'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self label: 'Button'; useRoundedCorners! !

!BasicButton methodsFor: 'initialization' stamp: 'sw 9/5/2007 15:31'!
label: aString font: aFontOrNil
	"Set the receiver's label and font as indicated."

	| oldLabel m aFont |
	(oldLabel _ self findA: StringMorph)
		ifNotNil: [oldLabel delete].
	aFont _ aFontOrNil ifNil: [Preferences standardEToysButtonFont].
	m _ StringMorph contents: aString font: aFont.
	self extent: (m width + 6) @ (m height + 6).
	m position: self center - (m extent // 2).
	self addMorph: m.
	m lock
! !


!BasicButton methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:56'!
addCustomMenuItems: aCustomMenu hand: aHandMorph 
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'change label...' translated action: #setLabel! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BasicButton class
	instanceVariableNames: ''!

!BasicButton class methodsFor: 'printing' stamp: 'sw 6/16/1998 16:58'!
defaultNameStemForInstances
	^ 'button'! !
Categorizer subclass: #BasicClassOrganizer
	instanceVariableNames: 'subject classComment commentStamp'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Classes'!

!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:02'!
classComment
	classComment
		ifNil: [^ ''].
	^ classComment text ifNil: ['']! !

!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'!
classComment: aString 
	"Store the comment, aString, associated with the object that refers to the 
	receiver."

	(aString isKindOf: RemoteString) 
		ifTrue: [classComment _ aString]
		ifFalse: [(aString == nil or: [aString size = 0])
			ifTrue: [classComment _ nil]
			ifFalse: [
				self error: 'use aClass classComment:'.
				classComment _ RemoteString newString: aString onFileNumber: 2]]
				"Later add priorSource and date and initials?"! !

!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'!
classComment: aString  stamp: aStamp
	"Store the comment, aString, associated with the object that refers to the receiver."

	self commentStamp: aStamp.
	(aString isKindOf: RemoteString) 
		ifTrue: [classComment _ aString]
		ifFalse: [(aString == nil or: [aString size = 0])
			ifTrue: [classComment _ nil]
			ifFalse:
				[self error: 'use aClass classComment:'.
				classComment _ RemoteString newString: aString onFileNumber: 2]]
				"Later add priorSource and date and initials?"! !

!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'!
commentRemoteStr
	^ classComment! !

!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'!
commentStamp
	"Answer the comment stamp for the class"

	^ commentStamp! !

!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'!
commentStamp: aStamp
	commentStamp _ aStamp! !

!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'!
dateCommentLastSubmitted
	"Answer a Date object indicating when my class comment was last submitted.  If there is no date stamp, or one of the old-time <historical>  guys, return nil"
	"RecentMessageSet organization dateCommentLastSubmitted"

	| aStamp tokens |
	(aStamp _ self commentStamp) isEmptyOrNil ifTrue: [^ nil].
	tokens _ aStamp findBetweenSubStrs: ' 
'.  "space is expected delimiter, but cr is sometimes seen, though of mysterious provenance"
	^ tokens size > 1
		ifTrue:
			[[tokens second asDate] ifError: [nil]]
		ifFalse:
			[nil]! !

!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'!
hasNoComment
	"Answer whether the class classified by the receiver has a comment."

	^classComment == nil! !

!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:04'!
hasSubject
	^ self subject notNil! !

!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:04'!
subject
	^ subject.! !


!BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'sw 9/6/2006 02:03'!
fileOutCommentOn: aFileStream moveSource: moveSource toFile: fileIndex
	"Copy the class comment to aFileStream.  If moveSource is true (as in compressChanges or compressSources) then update classComment to point to the new file."

	| fileComment |
	(classComment notNil and: [classComment text notNil]) ifTrue: 
		[aFileStream cr.
		fileComment _ RemoteString newString: classComment text
						onFileNumber: fileIndex toFile: aFileStream.
		moveSource ifTrue: [classComment _ fileComment]]! !

!BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 16:04'!
moveChangedCommentToFile: aFileStream numbered: fileIndex 
	"If the comment is in the changes file, then move it to a new file."

	(classComment ~~ nil and: [classComment sourceFileNumber > 1]) ifTrue: 
		[self fileOutCommentOn: aFileStream moveSource: true toFile: fileIndex]! !

!BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 16:04'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  Write a path to me in the other system instead."

	self hasSubject ifTrue: [
		(refStrm insideASegment and: [self subject isSystemDefined not]) ifTrue: [
			^ self].	"do trace me"
		(self subject isKindOf: Class) ifTrue: [
			dp _ DiskProxy global: self subject name selector: #organization args: #().
			refStrm replace: self with: dp.
			^ dp]].
	^ self	"in desparation"
! !

!BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'sw 9/6/2006 02:08'!
putCommentOnFile: aFileStream numbered: sourceIndex moveSource: moveSource forClass: aClass
	"Store the comment about the class onto file, aFileStream."

	| header |
	(classComment notNil and: [classComment text notNil]) ifTrue:
		[aFileStream cr; nextPut: $!!.
		header _ String streamContents: [:strm | 
				strm nextPutAll: aClass name;
				nextPutAll: ' commentStamp: '.
				commentStamp ifNil: [commentStamp _ '<historical>'].
				commentStamp storeOn: strm.
				strm nextPutAll: ' prior: '; nextPutAll: '0'].
		aFileStream nextChunkPut: header.
		aClass organization fileOutCommentOn: aFileStream
				moveSource: moveSource toFile: sourceIndex.
		aFileStream cr]! !


!BasicClassOrganizer methodsFor: 'private' stamp: 'NS 4/7/2004 16:04'!
setSubject: aClassDescription
	subject _ aClassDescription! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BasicClassOrganizer class
	instanceVariableNames: ''!

!BasicClassOrganizer class methodsFor: 'instance creation' stamp: 'NS 4/7/2004 16:04'!
class: aClassDescription
	^ self new setSubject: aClassDescription! !

!BasicClassOrganizer class methodsFor: 'instance creation' stamp: 'NS 4/7/2004 16:04'!
class: aClassDescription defaultList: aSortedCollection
	| inst |
	inst _ self defaultList: aSortedCollection.
	inst setSubject: aClassDescription.
	^ inst! !
Inspector subclass: #BasicInspector
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Inspector'!

!BasicInspector methodsFor: 'as yet unclassified' stamp: 'ajh 1/31/2003 15:49'!
inspect: anObject 
	"Initialize the receiver so that it is inspecting anObject. There is no 
	current selection."

	self initialize.
	object _ anObject.
	selectionIndex _ 0.
	contents _ ''! !
TestCase subclass: #BCCMTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Classes-Tests'!
!BCCMTest commentStamp: '<historical>' prior: 0!
This class contains some tests regarding the classes 
	Behavior
		ClassDescription
			Class
			Metaclass
---
	!


!BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 11:29'!
test01metaclassName


	self assert: Dictionary class  name = 'Dictionary class'.
	self assert: OrderedCollection class name = 'OrderedCollection class'.
	! !

!BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 11:28'!
test02metaclassNumberOfInstances


	self assert: Dictionary class allInstances size  = 1.
	self assert: OrderedCollection class allInstances size  = 1.! !

!BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 11:36'!
test03superclass


	| s |
	self assert: Dictionary superclass == Set.
	self assert: OrderedCollection superclass == SequenceableCollection.

	s _ OrderedCollection new.
	s add: SequenceableCollection.
	s add: Collection.
	s add: Object.
	s add: ProtoObject.

	self assert: OrderedCollection allSuperclasses = s.

	
	! !

!BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 11:39'!
test04metaclassSuperclass


	| s |
	self assert: Dictionary class superclass == Set class.
	self assert: OrderedCollection class superclass == SequenceableCollection class.

	! !

!BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 12:53'!
test05metaclassSuperclassHierarchy


	| s |
	
	self assert: SequenceableCollection class instanceCount  = 1.
	self assert: Collection class instanceCount  = 1.
	self assert: Object class instanceCount  = 1.
	self assert: ProtoObject class instanceCount  = 1.
	
	s _ OrderedCollection new.
	s add: SequenceableCollection class.
	s add: Collection class.
	s add: Object class.
	s add: ProtoObject class.

	s add: Class.
	s add: ClassDescription.
	s add: Behavior.
	s add: Object.
	s add: ProtoObject.

	self assert: OrderedCollection class allSuperclasses  = s.



	
	

	! !

!BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 12:53'!
test06ClassDescriptionAllSubInstances


	
	| cdNo clsNo metaclsNo |

	cdNo _ ClassDescription allSubInstances size.
	clsNo _ Class allSubInstances size .
	metaclsNo _ Metaclass allSubInstances size.

	self assert: cdNo = (clsNo + metaclsNo).

	
	
	



	
	

	! !

!BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 13:02'!
test07bmetaclassPointOfCircularity

	

	self assert: Metaclass class instanceCount = 1.
	self assert: Metaclass class someInstance == Metaclass.


	
	
	



	
	

	! !

!BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 12:16'!
test07metaclass

	

	self assert: OrderedCollection class class == Metaclass.
	self assert: OrderedCollection class class = Metaclass.

	self assert: Dictionary class class == Metaclass.
	self assert: Dictionary class class = Metaclass.


	self assert: Object class class == Metaclass.
	self assert: Object class class = Metaclass.



	
	
	



	
	

	! !

!BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 12:25'!
test08BCCMhierarchy

	

	self assert: Class superclass  == ClassDescription.
	self assert: Metaclass superclass == ClassDescription.

	self assert: ClassDescription superclass  == Behavior.
	self assert: Behavior superclass  = Object.


	self assert: Class class class ==  Metaclass.
	self assert: Metaclass class class  == Metaclass.
	self assert: ClassDescription class class == Metaclass.
	self assert: Behavior class class == Metaclass.




	
	
	



	
	

	! !

!BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 12:43'!
test09ObjectAllSubclasses

	| n2 |
	n2 _ Object allSubclasses size.
	self assert: n2 = (Object allSubclasses
			select: [:cls | cls class class == Metaclass
					or: [cls class == Metaclass]]) size! !
CrLfFileStream subclass: #BDFFontReader
	instanceVariableNames: 'properties'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Text'!
!BDFFontReader commentStamp: '<historical>' prior: 0!
I am a conversion utility for reading X11 Bitmap Distribution Format fonts.  My code is derived from the multilingual Squeak changeset written by OHSHIMA Yoshiki (ohshima@is.titech.ac.jp), although all support for fonts with more than 256 glyphs has been ripped out.  See http://www.is.titech.ac.jp/~ohshima/squeak/squeak-multilingual-e.html .

My class methods contain tools for fetching BDF source files from a well-known archive site, batch conversion to Squeak's .sf2 format, and installation of these fonts as TextStyles.  Also, the legal notices for the standard 75dpi fonts I process this way are included as "x11FontLegalNotices'.!


!BDFFontReader methodsFor: 'as yet unclassified' stamp: 'nop 1/18/2000 19:45'!
errorFileFormat
	self error: 'malformed bdf format'! !

!BDFFontReader methodsFor: 'as yet unclassified' stamp: 'nop 1/18/2000 19:46'!
errorUnsupported
	self error: 'unsupported bdf'! !

!BDFFontReader methodsFor: 'as yet unclassified' stamp: 'yo 5/10/2006 23:11'!
getLine

	| line |
	[(line _ self upTo: Character cr) size = 0] whileTrue.
	^ line.
! !

!BDFFontReader methodsFor: 'as yet unclassified' stamp: 'nop 1/18/2000 19:44'!
initialize
	properties _ Dictionary new.! !

!BDFFontReader methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 05:08'!
read
	| xTable strikeWidth glyphs ascent descent minAscii maxAscii maxWidth chars charsNum height form encoding bbx array width blt lastAscii pointSize ret stream |
	form _ encoding _ bbx _ nil.
	self initialize.
	self readAttributes.
	height _ Integer readFromString: ((properties at: #FONTBOUNDINGBOX) at: 2).
	ascent _ Integer readFromString: (properties at: 'FONT_ASCENT' asSymbol) first.
	descent _ Integer readFromString: (properties at: 'FONT_DESCENT' asSymbol) first.
	pointSize _ (Integer readFromString: (properties at: 'POINT_SIZE' asSymbol) first) // 10.
	
	maxWidth _ 0.
	minAscii _ 9999.
	strikeWidth _ 0.
	maxAscii _ 0.

	charsNum _ Integer readFromString: (properties at: #CHARS) first.
	chars _ Set new: charsNum.

	1 to: charsNum do: [:i |
		array _ self readOneCharacter.
		stream _ ReadStream on: array.
		form _ stream next.
		encoding _ stream next.
		bbx _ stream next.
		form ifNotNil: [
			width _ bbx at: 1.
			maxWidth _ maxWidth max: width.
			minAscii _ minAscii min: encoding.
			maxAscii _ maxAscii max: encoding.
			strikeWidth _ strikeWidth + width.
			chars add: array.
		].
	].

	chars _ chars asSortedCollection: [:x :y | (x at: 2) <= (y at: 2)].
	charsNum _ chars size. "undefined encodings make this different"

	charsNum > 256 ifTrue: [
		"it should be 94x94 charset, and should be fixed width font"
		strikeWidth _ 94*94*maxWidth.
		maxAscii _ 94*94.
		minAscii _ 0.
		xTable _ XTableForFixedFont new.
		xTable maxAscii: 94*94.
		xTable width: maxWidth.
	] ifFalse: [
		xTable _ (Array new: 258) atAllPut: 0.
	].

	glyphs _ Form extent: strikeWidth@height.
	blt _ BitBlt toForm: glyphs.
	lastAscii _ 0.
	
	charsNum > 256 ifTrue: [
		1 to: charsNum do: [:i |
			stream _ ReadStream on: (chars at: i).
			form _ stream next.
			encoding _ stream next.
			bbx _ stream next.
			encoding _ ((encoding // 256) - 33) * 94 + ((encoding \\ 256) - 33).
			blt copy: ((encoding * maxWidth)@0 extent: maxWidth@height)
				from: 0@0 in: form.
		].
	] ifFalse: [
		1 to: charsNum do: [:i |
			stream _ ReadStream on: (chars at: