Unauthorized

'From Pharo1.0beta of 16 May 2008 [Latest update: #10487] on 19 October 2009 at 4:57:33 pm'! BracketSliderMorph subclass: #AColorSelectorMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !AColorSelectorMorph commentStamp: 'gvc 5/18/2007 13:52' prior: 0! ColorComponentSelector showing an alpha gradient over a hatched background.! !AColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/3/2009 13:43'! color: aColor "Set the gradient colors." super color: aColor asNontranslucentColor. self fillStyle: self defaultFillStyle! ! !AColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/3/2009 13:43'! defaultFillStyle "Answer the hue gradient." ^(GradientFillStyle colors: {self color alpha: 0. self color}) origin: self topLeft; direction: (self bounds isWide ifTrue: [self width@0] ifFalse: [0@self height])! ! !AColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 09:17'! hatchForm "Answer a form showing a grid hatch pattern." ^ColorPresenterMorph hatchForm! ! !AColorSelectorMorph methodsFor: 'drawing' stamp: 'gvc 9/19/2006 14:28'! drawOn: aCanvas "Draw a hatch pattern first." aCanvas fillRectangle: self innerBounds fillStyle: (InfiniteForm with: self hatchForm). super drawOn: aCanvas ! ! !AColorSelectorMorph methodsFor: 'initialization' stamp: 'gvc 9/26/2006 11:54'! initialize "Initialize the receiver." super initialize. self value: 1.0; color: Color black! ! !AColorSelectorMorph methodsFor: 'visual properties' stamp: 'gvc 9/19/2006 15:46'! fillStyle: fillStyle "If it is a color then override with gradient." fillStyle isColor ifTrue: [self color: fillStyle] ifFalse: [super fillStyle: fillStyle]! ! TestCase subclass: #ATestCase instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Traits'! !ATestCase methodsFor: 'as yet unclassified' stamp: 'oscar.nierstrasz 10/18/2009 14:59'! testRequirement " self debug: #testRequirement " | class | class := Object subclass: #AClassForTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self class category. [ class compile: 'call ^ self isCalled'. self assert: (class requiredSelectors includes: #isCalled). class compile: 'isCalled ^ 1'. "Fail here:" self deny: (class requiredSelectors includes: #isCalled)] ensure: [class removeFromSystem. RequiredSelectors current clearOut: class ] ! ! Exception subclass: #Abort instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: '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! ! DialogWindow subclass: #AboutDialogWindow instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !AboutDialogWindow commentStamp: 'gvc 5/18/2007 13:53' prior: 0! Default superclass for application about dialogs.! !AboutDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/12/2007 16:32'! newButtons "Answer new buttons as appropriate." ^{self newCloseButton isDefault: true}! ! Object subclass: #AbstractEvent instanceVariableNames: 'item itemKind environment' classVariableNames: '' poolDictionaries: '' category: 'System-Change Notification'! !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 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 class instanceVariableNames: ''! !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: 'instance creation' stamp: 'ab 2/10/2005 16:32'! classCategory: aName ^ self item: aName kind: AbstractEvent categoryKind.! ! !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: '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... "! ! Object subclass: #AbstractFont instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Fonts'! !AbstractFont commentStamp: '' prior: 0! AbstractFont defines the generic interface that all fonts need to implement.! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 7/29/2006 14:36'! displayStrikeoutOn: aDisplayContext from: baselineStartPoint to: baselineEndPoint "display the strikeout if appropriate for the receiver"! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 7/29/2006 13:51'! displayUnderlineOn: aDisplayContext from: baselineStartPoint to: baselineEndPoint "display the underline if appropriate for the receiver"! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 8/10/2006 07:16'! emphasisString "Answer a translated string that represents the receiver's emphasis." ^self emphasisStringFor: self emphasis! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 8/10/2006 07:13'! emphasisStringFor: emphasisCode "Answer a translated string that represents the attributes given in emphasisCode." ^self class emphasisStringFor: emphasisCode! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 3/29/2007 13:43'! hasDistinctGlyphsForAll: asciiString "Answer true if the receiver has glyphs for all the characters in asciiString and no single glyph is shared by more than one character, false otherwise. The default behaviour is to answer true, but subclasses may reimplement" ^true! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 3/29/2007 13:25'! hasGlyphsForAll: asciiString "Answer true if the receiver has glyphs for all the characters in asciiString, false otherwise. The default behaviour is to answer true, but subclasses may reimplement" ^true! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 4/6/2007 12:58'! isSubPixelPositioned "Answer true if the receiver is currently using subpixel positioned glyphs, false otherwise. This affects how padded space sizes are calculated when composing text. Currently, only FreeTypeFonts are subPixelPositioned, and only when not Hinted" ^false ! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 3/29/2007 13:32'! isSymbolFont "Answer true if the receiver is a Symbol font, false otherwise. The default is to answer false, subclasses can reimplement" ^false! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 3/10/2007 13:08'! kerningLeft: leftChar right: rightChar ^0! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 3/31/2007 20:17'! linearWidthOf: aCharacter "This is the scaled, unrounded advance width." ^self widthOf: aCharacter! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 4/3/2007 16:47'! widthAndKernedWidthOfLeft: leftCharacter right: rightCharacterOrNil into: aTwoElementArray "Set the first element of aTwoElementArray to the width of leftCharacter and the second element to the width of left character when kerned with rightCharacterOrNil. Answer aTwoElementArray" | w k | w := self widthOf: leftCharacter. rightCharacterOrNil isNil ifTrue:[ aTwoElementArray at: 1 put: w; at: 2 put: w] ifFalse:[ k := self kerningLeft: leftCharacter right: rightCharacterOrNil. aTwoElementArray at: 1 put: w; at: 2 put: w+k]. ^aTwoElementArray ! ! !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: 'caching' stamp: 'nk 3/15/2004 18:47'! releaseCachedState ! ! !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: 'lr 7/4/2009 10:42'! 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: 'ar 5/19/2000 14:58'! widthOf: aCharacter "Return the width of the given character" ^self subclassResponsibility! ! !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: 'lr 7/4/2009 10:42'! 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: 'sps 3/23/2004 15:50'! widthOfStringOrText: aStringOrText aStringOrText ifNil:[^0]. ^aStringOrText isText ifTrue:[self approxWidthOfText: aStringOrText ] ifFalse:[self widthOfString: aStringOrText ] ! ! !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: 'testing' stamp: 'yo 2/12/2007 19:34'! isFontSet ^ false. ! ! !AbstractFont methodsFor: 'testing' stamp: 'nk 6/25/2003 12:54'! isTTCFont ^false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractFont class instanceVariableNames: ''! !AbstractFont class methodsFor: 'as yet unclassified' stamp: 'eem 6/11/2008 12:35'! emphasisStringFor: emphasisCode "Answer a translated string that represents the attributes given in emphasisCode." | emphases | 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. ^String streamContents: [ :s | | bit | bit := 1. [ 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 ]. ]! ! DialogWindow subclass: #AbstractFontSelectorDialogWindow instanceVariableNames: 'fontFamilies selectedFont textPreviewMorph fontFamilyIndex fontSizeIndex isBold isItalic isUnderlined isStruckOut previewText' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !AbstractFontSelectorDialogWindow commentStamp: 'gvc 5/18/2007 13:04' prior: 0! Dialog based font chooser with preview.! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:40'! fontFamilies "Answer the set of available fonts families that are supported as Text objects in the font that they represent." ^fontFamilies ifNil: [ self fontFamilies: self defaultFontFamilies. fontFamilies]! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:02'! fontFamilies: anObject "Set the value of fontFamilies" fontFamilies := anObject! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 14:30'! fontFamilyIndex "Answer the value of fontFamilyIndex" ^ fontFamilyIndex! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:19'! fontFamilyIndex: anObject "Set the value of fontFamilyIndex" fontFamilyIndex := anObject. self updateSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 14:30'! fontSizeIndex "Answer the value of fontSizeIndex" ^ fontSizeIndex! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:19'! fontSizeIndex: anObject "Set the value of fontSizeIndex" fontSizeIndex := anObject. self updateSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:12'! isBold "Answer the value of isBold" ^ isBold! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:07'! isBold: anObject "Set the value of isBold" isBold := anObject. self changed: #isBold! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:12'! isItalic "Answer the value of isItalic" ^ isItalic! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:07'! isItalic: anObject "Set the value of isItalic" isItalic := anObject. self changed: #isItalic! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:12'! isStruckOut "Answer the value of isStruckOut" ^ isStruckOut! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:07'! isStruckOut: anObject "Set the value of isStruckOut" isStruckOut := anObject. self changed: #isStruckOut! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:12'! isUnderlined "Answer the value of isUnderlined" ^ isUnderlined! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:07'! isUnderlined: anObject "Set the value of isUnderlined" isUnderlined := anObject. self changed: #isUnderlined! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:30'! previewText "Answer the value of previewText" ^previewText asText addAttribute: (TextEmphasis new emphasisCode: self textEmphasisCode)! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/18/2007 13:07'! previewText: anObject "Set the value of previewText" previewText := anObject. self changed: #previewText! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 13:41'! selectedFont "Answer the value of selectedFont" ^ selectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 10/9/2007 14:19'! selectedFont: anObject "Set the value of selectedFont" selectedFont := anObject ifNil: [TextStyle defaultFont]. self updateFromSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 13:41'! textPreviewMorph "Answer the value of textPreviewMorph" ^ textPreviewMorph! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 13:41'! textPreviewMorph: anObject "Set the value of textPreviewMorph" textPreviewMorph := anObject! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/26/2008 15:49'! defaultFontFamilies "Answer the set of available fonts families that are supported in the font that they represent." self subclassResponsibility! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/26/2008 15:31'! defaultPreviewText "Answer the default text to use for the preview of the font." ^(33 to: 127) asByteArray asString! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 15:47'! familyName "Answer the selected family name or nil if none." (self fontFamilyIndex between: 1 and: self fontFamilies size) ifFalse: [^nil]. ^(self fontFamilies at: self fontFamilyIndex) asString! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 16:03'! fontSize "Answer the selected font size or nil if none." (self fontSizeIndex between: 1 and: self fontSizes size) ifFalse: [^nil]. ^self fontSizes at: self fontSizeIndex! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 14:31'! fontSizes "Answer the set of available fonts sizes that are supported." ^#(6 7 8 9 10 11 12 13 14 15 16 18 20 21 22 24 26 28 32 36 48)! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:22'! initialize "Initialize the receiver." self isBold: false; isItalic: false; isUnderlined: false; isStruckOut: false; previewText: self defaultPreviewText; fontFamilyIndex: 0; fontSizeIndex: 0. super initialize! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 7/16/2007 13:43'! isFreeTypeInstalled "Answer whether FreeType appears to be installed." ^Smalltalk includesKey: #FreeTypeFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/26/2008 15:35'! matchingFont "Answer the font that matches the selections." self subclassResponsibility! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:02'! newBoldButtonMorph "Answer a button for the boldness of the font." ^self newButtonFor: self getState: #isBold action: #toggleBold arguments: nil getEnabled: nil labelForm: self theme smallBoldIcon help: 'Toggle bold font' translated! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:48'! newContentMorph "Answer a new content morph." self textPreviewMorph: self newTextPreviewMorph. ^(self newColumn: { (self newRow: { self newGroupbox: 'Family' translated for: self newFontFamilyMorph. (self newColumn: { (self newGroupbox: 'Style' translated for: self newFontStyleButtonRowMorph) vResizing: #shrinkWrap. self newGroupbox: 'Point size' translated for: self newFontSizeMorph}) hResizing: #shrinkWrap}) vResizing: #spaceFill. (self newGroupbox: 'Preview' translated for: self textPreviewMorph) vResizing: #shrinkWrap}) minWidth: 350; minHeight: 400! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 11:49'! newFontFamilyMorph "Answer a list for the font family of the font." |highestFont| highestFont := self fontFamilies first fontAt: 1 withStyle: TextStyle default. self fontFamilies do: [:ff | |f| f := ff fontAt: 1 withStyle: TextStyle default. f height > highestFont height ifTrue: [highestFont := f]]. ^(self newListFor: self list: #fontFamilies selected: #fontFamilyIndex changeSelected: #fontFamilyIndex: help: nil) font: highestFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 11:49'! newFontSizeMorph "Answer a list for the font size of the font." ^self newListFor: self list: #fontSizes selected: #fontSizeIndex changeSelected: #fontSizeIndex: help: nil! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:48'! newFontStyleButtonRowMorph "Answer a new font style button row morph." ^self newRow: { self newBoldButtonMorph. self newItalicButtonMorph. self newUnderlinedButtonMorph. self newStruckOutButtonMorph}! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:02'! newItalicButtonMorph "Answer a button for the italic emphasis of the font." ^self newButtonFor: self getState: #isItalic action: #toggleItalic arguments: nil getEnabled: nil labelForm: self theme smallItalicIcon help: 'Toggle italic font' translated! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:02'! newStruckOutButtonMorph "Answer a button for the struck out emphasis of the font." ^self newButtonFor: self getState: #isStruckOut action: #toggleStruckOut arguments: nil getEnabled: nil labelForm: self theme smallStrikeOutIcon help: 'Toggle struck-out font' translated! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 16:31'! newTextPreviewMorph "Answer a text entry morph for the preview of the font." ^(self newTextEditorFor: self getText: #previewText setText: nil getEnabled: nil) vResizing: #rigid; enabled: false; extent: 20@90! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:02'! newUnderlinedButtonMorph "Answer a button for the italic emphasis of the font." ^self newButtonFor: self getState: #isUnderlined action: #toggleUnderlined arguments: nil getEnabled: nil labelForm: self theme smallUnderlineIcon help: 'Toggle underlined font' translated! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:33'! textEmphasisCode "Answer the current bitmask for the text emphasis." ^(((self isBold ifTrue: [1] ifFalse: [0]) bitOr: (self isItalic ifTrue: [2] ifFalse: [0])) bitOr: (self isUnderlined ifTrue: [4] ifFalse: [0])) bitOr: (self isStruckOut ifTrue: [16] ifFalse: [0])! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 15:31'! toggleBold "Toggle the font bold emphasis." self isBold: self isBold not. self updateSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 15:31'! toggleItalic "Toggle the font italic emphasis." self isItalic: self isItalic not. self updateSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 15:31'! toggleStruckOut "Toggle the font struck out emphasis." self isStruckOut: self isStruckOut not. self updateSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 15:31'! toggleUnderlined "Toggle the font underlined emphasis." self isUnderlined: self isUnderlined not. self updateSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:21'! updateFromSelectedFont "Update our state based on the selected font." self subclassResponsibility! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/4/2007 10:25'! updateSelectedFont "Update the selected font to reflect the choices." self selectedFont: self matchingFont! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractFontSelectorDialogWindow class instanceVariableNames: ''! !AbstractFontSelectorDialogWindow class methodsFor: 'as yet unclassified' stamp: 'gvc 5/21/2007 12:42'! taskbarIcon "Answer the icon for the receiver in a task bar." ^MenuIcons smallFontsIcon! ! Model subclass: #AbstractHierarchicalList instanceVariableNames: 'currentSelection' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Explorer'! !AbstractHierarchicalList commentStamp: '' 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: '' 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: '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 methodsFor: 'private' stamp: 'dc 5/30/2008 10:17'! 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 := (aString findTokens: ' ') readStream. [ 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: 'marcus.denker 9/14/2008 18:54'! parameters parameters ifNil: [parameters := self class extractParameters]. ^parameters! ! !AbstractLauncher methodsFor: 'private' stamp: 'mir 7/29/1999 10:21'! parameters: startupParameters parameters := startupParameters! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractLauncher class instanceVariableNames: ''! !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! ! !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! ! Object subclass: #AbstractObjectsAsMethod instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-ObjectsAsMethods'! !AbstractObjectsAsMethod methodsFor: 'as yet unclassified' stamp: 'md 3/1/2006 14:25'! flushCache! ! !AbstractObjectsAsMethod methodsFor: 'as yet unclassified' stamp: 'md 3/1/2006 14:23'! methodClass: aMethodClass! ! !AbstractObjectsAsMethod methodsFor: 'as yet unclassified' stamp: 'md 3/1/2006 14:23'! selector: aSymbol! ! Morph subclass: #AbstractResizerMorph instanceVariableNames: 'dotColor handleColor lastMouse' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Windows'! !AbstractResizerMorph commentStamp: 'jmv 1/29/2006 17:15' prior: 0! I am the superclass of a hierarchy of morph specialized in allowing the user to resize or rearrange windows and panes.! !AbstractResizerMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/27/2008 21:34'! adoptPaneColor: paneColor "Just get the resizer fill style for the theme." paneColor ifNil: [^super adoptPaneColor: paneColor]. self fillStyle: (self theme resizerGripNormalFillStyleFor: self)! ! !AbstractResizerMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/12/2007 10:59'! mouseUp: anEvent "Change the cursor back to normal if necessary." (self bounds containsPoint: anEvent cursorPoint) ifFalse: [ anEvent hand showTemporaryCursor: nil. self setDefaultColors; changed]! ! !AbstractResizerMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/13/2008 10:20'! shouldDraw "Answer whether the resizer should be drawn." ^self fillStyle isTransparent not! ! !AbstractResizerMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/13/2008 10:35'! shouldInvalidateOnMouseTransition "Answer whether the resizer should be invalidated when the mouse enters or leaves." ^false! ! !AbstractResizerMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/13/2008 10:36'! mouseEnter: anEvent self isCursorOverHandle ifTrue: [self setInverseColors. self shouldInvalidateOnMouseTransition ifTrue: [self changed]. "avoid unnecessary invalidation" anEvent hand showTemporaryCursor: self resizeCursor]! ! !AbstractResizerMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/13/2008 10:36'! mouseLeave: anEvent anEvent hand showTemporaryCursor: nil. self setDefaultColors. self shouldInvalidateOnMouseTransition ifTrue: [self changed]. "avoid unnecessary invalidation"! ! !AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:36'! dotColor ^ dotColor ifNil: [self setDefaultColors. dotColor]! ! !AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:35'! handleColor ^ handleColor ifNil: [self setDefaultColors. handleColor]! ! !AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:37'! handlesMouseDown: anEvent ^ true! ! !AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:37'! handlesMouseOver: anEvent ^ true ! ! !AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'md 2/24/2006 23:01'! initialize super initialize. self color: Color transparent! ! !AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:40'! isCursorOverHandle ^ true! ! !AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:42'! mouseDown: anEvent lastMouse := anEvent cursorPoint! ! !AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:37'! resizeCursor self subclassResponsibility! ! !AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/29/2005 13:25'! setDefaultColors handleColor := Color lightGray lighter lighter. dotColor := Color gray lighter! ! !AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/30/2005 21:30'! setInverseColors handleColor := Color lightGray. dotColor := Color white! ! 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: '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! ! !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! ! PluggableTextMorph subclass: #AcceptableCleanTextMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Pluggable Widgets'! !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: 'Files-Directories'! !AcornFileDirectory methodsFor: 'file name utilities' stamp: 'stephaneducasse 2/4/2006 20:31'! 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: '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 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: 'private' stamp: 'stephaneducasse 2/4/2006 20:31'! 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 class instanceVariableNames: ''! !AcornFileDirectory class methodsFor: '*network-uri' stamp: 'tpr 5/4/2005 17:22'! privateFullPathForURI: aURI "derive the full filepath from aURI" | first path | path := String streamContents: [ :s | first := false. aURI pathComponents do: [ :p | first ifTrue: [ s nextPut: self pathNameDelimiter ]. first := true. s nextPutAll: p ] ]. ^path unescapePercents ! ! !AcornFileDirectory class methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:32'! 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"! ! !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" ^ $/ ! ! HostWindowProxy subclass: #AcornWindowProxy instanceVariableNames: 'flags' classVariableNames: 'BackButton CloseButton HasTitleBar IconiseButton ToggleSizeButton' poolDictionaries: '' category: 'Graphics-External-Ffenestri'! !AcornWindowProxy methodsFor: 'window decorations' stamp: 'tpr 10/6/2004 16:32'! addButton: buttonFlag "we need a button on the window. If there is already one, ignore this. If the host window does not yet exist we need only set the flag. If there is already a window, we will need to destroy the old window, add the flag and recreate" "do we already have a button? - if so just return" (self hasButton: buttonFlag) ifTrue:[^self]. "add the close button flag" self addFlag: buttonFlag. "note that we have a titlebar in order for the button to exist" self addFlag: HasTitleBar. "if we have a window recreate it" self isOpen ifTrue:[self recreate]! ! !AcornWindowProxy methodsFor: 'window decorations' stamp: 'tpr 10/6/2004 15:01'! addCloseButton "we need a close button on the window. If there is already one, ignore this. If the host window does not yet exist we need only set the flag. If there is already a window, we will need to destroy the old window, add the flag and recreate" ^self addButton: CloseButton! ! !AcornWindowProxy methodsFor: 'window decorations' stamp: 'lr 7/4/2009 10:42'! addFlag: flagVal "add flagVal to the flags" flags ifNil: [ flags := 0 ]. flags := flags bitOr: flagVal! ! !AcornWindowProxy methodsFor: 'window decorations' stamp: 'tpr 10/6/2004 15:01'! addIconiseButton "we need a iconise button on the window. If there is already one, ignore this. If the host window does not yet exist we need only set the flag. If there is already a window, we will need to destroy the old window, add the flag and recreate" ^self addButton: IconiseButton! ! !AcornWindowProxy methodsFor: 'window decorations' stamp: 'tpr 10/6/2004 15:25'! addToggleSizeButton "we need a toggle size button on the window. If there is already one, ignore this. If the host window does not yet exist we need only set the flag. If there is already a window, we will need to destroy the old window, add the flag and recreate" ^self addButton: ToggleSizeButton! ! !AcornWindowProxy methodsFor: 'window decorations' stamp: 'lr 7/4/2009 10:42'! attributes | val | ^ flags ifNil: [ super attributes ] ifNotNil: [ (val := ByteArray new: 4) longAt: 1 put: flags bigEndian: false. val ]! ! !AcornWindowProxy methodsFor: 'window decorations' stamp: 'tpr 10/7/2004 11:37'! defaultWindowType "set myself up for use as a normal window titlebar, close, iconise & size buttons" self addCloseButton; addIconiseButton; addToggleSizeButton! ! !AcornWindowProxy methodsFor: 'window decorations' stamp: 'tpr 10/6/2004 15:20'! hasButton: buttonFlag "do I have the button?" flags ifNil:[^false]. ^flags anyMask: buttonFlag! ! !AcornWindowProxy methodsFor: 'window decorations' stamp: 'tpr 10/11/2004 18:31'! hasTitleBar "do I have a title bar set?" ^self hasButton: HasTitleBar! ! !AcornWindowProxy methodsFor: 'window decorations' stamp: 'tpr 10/6/2004 16:33'! windowTitle: titleString "set the window title. If the window is open and doesn't already have a titlebar, add the title bar, recreate and set the title" (self isOpen and: [self hasTitleBar not]) ifTrue:[ "note that we have a titlebar in order for the title to exist" self addFlag: HasTitleBar. self recreate]. super windowTitle: titleString! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AcornWindowProxy class instanceVariableNames: ''! !AcornWindowProxy class methodsFor: 'class initialization' stamp: 'lr 7/4/2009 10:42'! initialize "AcornWindowProxy initialize" "Encode attributes in a 4byte ByteArary to be treated as an int in the vm" BackButton := 16777216. CloseButton := 33554432. IconiseButton := 0. "handled by OS completely independently" ToggleSizeButton := 134217728. HasTitleBar := 67108864! ! !AcornWindowProxy class methodsFor: 'system startup' stamp: 'tpr 10/1/2004 16:28'! isActiveHostWindowProxyClass "Am I active?" ^SmalltalkImage current platformName = 'RiscOS'! ! Array variableSubclass: #ActionSequence instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Object Events'! !ActionSequence commentStamp: 'tlk 5/7/2006 20:02' prior: 0! An ActionSequence is an array that lists the object's dependant objects.! !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: $)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ActionSequence class instanceVariableNames: ''! AbstractEvent subclass: #AddedEvent instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Change Notification'! !AddedEvent methodsFor: 'printing' stamp: 'rw 6/30/2003 09:31'! printEventKindOn: aStream aStream nextPutAll: 'Added'! ! !AddedEvent methodsFor: 'testing' stamp: 'rw 6/30/2003 08:35'! isAdded ^true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 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 variableSubclass: #AdditionalMethodState instanceVariableNames: 'method selector' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! !AdditionalMethodState commentStamp: '' prior: 0! I am class holding state for compiled methods. All my instance variables should be actually part of the CompiledMethod itself, but the current implementation of the VM doesn't allow this. Currently I hold the selector and any pragmas or properties the compiled method has. Pragmas and properties are stored in indexable fields; pragmas as instances of Pragma, properties as instances of Association. I am a reimplementation of much of MethodProperties, but eliminating the explicit properties and pragmas dictionaries. Hence I answer true to isMethodProperties.! !AdditionalMethodState methodsFor: 'testing' stamp: 'eem 11/27/2008 13:12'! analogousCodeTo: aMethodProperties | bs | (bs := self basicSize) ~= aMethodProperties basicSize ifTrue: [^false]. 1 to: bs do: [:i| ((self basicAt: i) analogousCodeTo: (aMethodProperties basicAt: i)) ifFalse: [^false]]. ^true! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'bgf 12/6/2008 12:15'! hasLiteralSuchThat: aBlock "Answer true if litBlock returns true for any literal in this array, even if embedded in further array structure. This method is only intended for private use by CompiledMethod hasLiteralSuchThat:" 1 to: self basicSize do: [:i | | propertyOrPragma "" | propertyOrPragma := self basicAt: i. (propertyOrPragma isVariableBinding ifTrue: [(aBlock value: propertyOrPragma key) or: [(aBlock value: propertyOrPragma value) or: [propertyOrPragma value isArray and: [propertyOrPragma value hasLiteralSuchThat: aBlock]]]] ifFalse: [propertyOrPragma hasLiteralSuchThat: aBlock]) ifTrue: [^true]]. ^false! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'eem 11/29/2008 16:40'! hasLiteralThorough: literal "Answer true if any literal in these properties is literal, even if embedded in array structure." 1 to: self basicSize do: [:i | | propertyOrPragma "" | propertyOrPragma := self basicAt: i. (propertyOrPragma isVariableBinding ifTrue: [propertyOrPragma key == literal or: [propertyOrPragma value == literal or: [propertyOrPragma value isArray and: [propertyOrPragma value hasLiteral: literal]]]] ifFalse: [propertyOrPragma hasLiteral: literal]) ifTrue: [^true]]. ^false! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'eem 12/1/2008 10:53'! includes: aPropertyOrPragma "" "Test if the property or pragma is present." 1 to: self basicSize do: [:i | (self basicAt: i) = aPropertyOrPragma ifTrue: [^true]]. ^false! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'eem 12/1/2008 10:53'! includesKey: aKey "Test if the property aKey or pragma with selector aKey is present." 1 to: self basicSize do: [:i | (self basicAt: i) key == aKey ifTrue: [^true]]. ^false! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'eem 11/29/2008 13:47'! isEmpty ^self basicSize = 0! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'md 2/19/2006 11:24'! isMethodProperties ^true! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'eem 12/1/2008 16:49'! notEmpty ^self basicSize > 0! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'JohanBrichau 10/7/2009 20:07'! refersToLiteral: aLiteral ^ self pragmas anySatisfy: [ :pragma | pragma hasLiteral: aLiteral ]! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 10:19'! at: aKey "Answer the property value or pragma associated with aKey." ^self at: aKey ifAbsent: [self error: 'not found']! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 12/1/2008 10:55'! at: aKey ifAbsent: aBlock "Answer the property value or pragma associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock." 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) key == aKey ifTrue: [^propertyOrPragma isVariableBinding ifTrue: [propertyOrPragma value] ifFalse: [propertyOrPragma]]]. ^aBlock value! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 12/1/2008 10:54'! at: aKey ifAbsentPut: aBlock "Answer the property value or pragma associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock." 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) key == aKey ifTrue: [^propertyOrPragma isVariableBinding ifTrue: [propertyOrPragma value] ifFalse: [propertyOrPragma]]]. ^method propertyValueAt: aKey put: aBlock value! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 12/1/2008 10:56'! at: aKey put: aValue "Replace the property value or pragma associated with aKey." 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) key == aKey ifTrue: [propertyOrPragma isVariableBinding ifTrue: [propertyOrPragma value: aValue] ifFalse: [self basicAt: i put: aValue]]]. ^method propertyValueAt: aKey put: aValue! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 18:36'! keysAndValuesDo: aBlock "Enumerate the receiver with all the keys and values." 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) isVariableBinding ifTrue: [aBlock value: propertyOrPragma key value: propertyOrPragma value] ifFalse: [aBlock value: propertyOrPragma keyword value: propertyOrPragma]]! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 14:11'! pragmas "Answer the raw messages comprising my pragmas." | pragmaStream | pragmaStream := WriteStream on: (Array new: self basicSize). 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) isVariableBinding ifFalse: [pragmaStream nextPut: propertyOrPragma]]. ^pragmaStream contents! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 10:25'! properties | propertyStream | propertyStream := WriteStream on: (Array new: self basicSize * 2). 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) isVariableBinding ifTrue: [propertyStream nextPut: propertyOrPragma key; nextPut: propertyOrPragma value]]. ^IdentityDictionary newFromPairs: propertyStream contents! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 19:32'! removeKey: aKey ifAbsent: aBlock "Remove the property with aKey. Answer the value or, if aKey isn't found, answer the result of evaluating aBlock." 1 to: self basicSize do: [:i | | propertyOrPragma "" | propertyOrPragma := self basicAt: i. (propertyOrPragma isVariableBinding ifTrue: [propertyOrPragma key] ifFalse: [propertyOrPragma keyword]) == aKey ifTrue: [^method removeProperty: aKey]]. ^aBlock value! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'md 2/16/2006 17:50'! selector ^selector! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'md 2/16/2006 17:50'! selector: aSymbol selector := aSymbol! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 18:28'! setMethod: aMethod method := aMethod. 1 to: self basicSize do: [:i| | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) isVariableBinding ifFalse: [propertyOrPragma setMethod: aMethod]]! ! !AdditionalMethodState methodsFor: 'copying' stamp: 'eem 11/29/2008 18:35'! copyWith: aPropertyOrPragma "" "Answer a copy of the receiver which includes aPropertyOrPragma" | bs copy | (Association == aPropertyOrPragma class or: [Pragma == aPropertyOrPragma class]) ifFalse: [self error: self class name, ' instances should hold only Associations or Pragmas.']. copy := self class new: (bs := self basicSize) + 1. 1 to: bs do: [:i| copy basicAt: i put: (self basicAt: i)]. copy basicAt: bs + 1 put: aPropertyOrPragma. ^copy selector: selector; setMethod: method; yourself ! ! !AdditionalMethodState methodsFor: 'copying' stamp: 'eem 11/29/2008 18:35'! copyWithout: aPropertyOrPragma "" "Answer a copy of the receiver which no longer includes aPropertyOrPragma" | bs copy offset | copy := self class new: (bs := self basicSize) - ((self includes: aPropertyOrPragma) ifTrue: [1] ifFalse: [0]). offset := 0. 1 to: bs do: [:i| (self basicAt: i) = aPropertyOrPragma ifTrue: [offset := 1] ifFalse: [copy basicAt: i - offset put: (self basicAt: i)]]. ^copy selector: selector; setMethod: method; yourself ! ! !AdditionalMethodState methodsFor: 'properties' stamp: 'eem 11/29/2008 10:28'! includesProperty: aKey "Test if the property aKey is present." 1 to: self basicSize do: [:i | | propertyOrPragma "" | propertyOrPragma := self basicAt: i. (propertyOrPragma isVariableBinding and: [propertyOrPragma key == aKey]) ifTrue: [^true]]. ^false! ! !AdditionalMethodState methodsFor: 'properties' stamp: 'eem 11/29/2008 10:18'! propertyKeysAndValuesDo: aBlock "Enumerate the receiver with all the keys and values." 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) isVariableBinding ifTrue: [aBlock value: propertyOrPragma key value: propertyOrPragma value]]! ! !AdditionalMethodState methodsFor: 'properties' stamp: 'eem 11/29/2008 11:46'! propertyValueAt: aKey "Answer the property value associated with aKey." ^ self propertyValueAt: aKey ifAbsent: [ self error: 'Property not found' ].! ! !AdditionalMethodState methodsFor: 'properties' stamp: 'eem 11/29/2008 11:45'! propertyValueAt: aKey ifAbsent: aBlock "Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock." 1 to: self basicSize do: [:i | | propertyOrPragma "" | propertyOrPragma := self basicAt: i. (propertyOrPragma isVariableBinding and: [propertyOrPragma key == aKey]) ifTrue: [^propertyOrPragma value]]. ^aBlock value! ! !AdditionalMethodState methodsFor: 'properties' stamp: 'lr 2/6/2006 20:48'! removeKey: aKey "Remove the property with aKey. Answer the property or raise an error if aKey isn't found." ^ self removeKey: aKey ifAbsent: [ self error: 'Property not found' ].! ! !AdditionalMethodState methodsFor: 'decompiling' stamp: 'eem 6/11/2009 17:06'! method: aMethodNodeOrNil "For decompilation" method := aMethodNodeOrNil! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AdditionalMethodState class instanceVariableNames: ''! !AdditionalMethodState class methodsFor: 'instance creation' stamp: 'eem 11/29/2008 18:48'! forMethod: aMethod selector: aSelector ^(self basicNew: 0) selector: aSelector; setMethod: aMethod; yourself! ! !AdditionalMethodState class methodsFor: 'instance creation' stamp: 'eem 11/28/2008 12:26'! selector: aSelector with: aPropertyOrPragma ^(self basicNew: 1) selector: aSelector; basicAt: 1 put: aPropertyOrPragma; yourself! ! MessageDialogWindow subclass: #AlertDialogWindow instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !AlertDialogWindow commentStamp: 'gvc 5/18/2007 13:52' prior: 0! Message dialog with a warning icon.! !AlertDialogWindow methodsFor: 'visual properties' stamp: 'gvc 5/18/2007 10:27'! icon "Answer an icon for the receiver." ^self theme warningIcon! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AlertDialogWindow class instanceVariableNames: ''! !AlertDialogWindow class methodsFor: 'as yet unclassified' stamp: 'gvc 5/22/2007 11:50'! taskbarIcon "Answer the icon for the receiver in a task bar." ^self theme smallWarningIcon! ! 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: 'adding' stamp: 'stephane.ducasse 1/15/2009 15:52'! addAColumn: aCollectionOfMorphs | col | col := self inAColumn: aCollectionOfMorphs. self addMorphBack: col. ^col! ! !AlignmentMorph methodsFor: 'adding' stamp: 'stephane.ducasse 1/15/2009 15:52'! addARow: aCollectionOfMorphs | row | row := self inARow: aCollectionOfMorphs. self addMorphBack: row. ^row! ! !AlignmentMorph methodsFor: 'adding' stamp: 'stephane.ducasse 1/15/2009 15:52'! addARowCentered: aCollectionOfMorphs ^(self addARow: aCollectionOfMorphs) hResizing: #shrinkWrap; wrapCentering: #center; cellPositioning: #leftCenter! ! !AlignmentMorph methodsFor: 'adding' stamp: 'stephane.ducasse 1/15/2009 15:52'! addARowCentered: aCollectionOfMorphs cellInset: cellInsetInteger ^(self addARow: aCollectionOfMorphs) hResizing: #shrinkWrap; wrapCentering: #center; cellPositioning: #leftCenter; cellInset: cellInsetInteger! ! !AlignmentMorph methodsFor: 'classification' stamp: 'di 5/7/1998 01:20'! isAlignmentMorph ^ true ! ! !AlignmentMorph methodsFor: 'event handling' stamp: 'sw 5/6/1998 15:58'! wantsKeyboardFocusFor: aSubmorph aSubmorph wouldAcceptKeyboardFocus ifTrue: [^ true]. ^ super wantsKeyboardFocusFor: aSubmorph! ! !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: 'stephane.ducasse 1/15/2009 15:58'! initialize super initialize. self layoutPolicy: TableLayout new; listDirection: #leftToRight; wrapCentering: #topLeft; hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 2; rubberBandCells: true "from AlignmentMorphBob1which was merged in this class, in an effort to remove alignementBob1 and still preserving the addInRow behavior" " self listDirection: #topToBottom. self layoutInset: 0. self hResizing: #rigid. self vResizing: #rigid"! ! !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: '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 methodsFor: 'visual properties' stamp: 'stephane.ducasse 1/15/2009 15:52'! fancyText: aString font: aFont color: aColor | answer tm col | col := ColorTheme current dialog3DTitles ifTrue: [aColor] ifFalse: [aColor negated]. tm := TextMorph new. tm beAllFont: aFont; color: col; contents: aString. answer := self inAColumn: {tm}. ColorTheme current dialog3DTitles ifTrue: ["" tm addDropShadow. tm shadowPoint: 5 @ 5 + tm bounds center]. tm lock. ^ answer! ! !AlignmentMorph methodsFor: 'visual properties' stamp: 'stephane.ducasse 1/15/2009 15:53'! inAColumn: aCollectionOfMorphs | col | col := self class newColumn color: Color transparent; vResizing: #shrinkWrap; layoutInset: 1; wrapCentering: #center; cellPositioning: #topCenter. aCollectionOfMorphs do: [ :each | col addMorphBack: each]. ^col! ! !AlignmentMorph methodsFor: 'visual properties' stamp: 'stephane.ducasse 1/15/2009 15:54'! inARightColumn: aCollectionOfMorphs | col | col := self class newColumn color: Color transparent; vResizing: #shrinkWrap; layoutInset: 1; wrapCentering: #bottomRight; cellPositioning: #topCenter. aCollectionOfMorphs do: [:each | col addMorphBack: each]. ^ col! ! !AlignmentMorph methodsFor: 'visual properties' stamp: 'stephane.ducasse 1/15/2009 15:55'! inARow: aCollectionOfMorphs | row | row := self class newRow color: Color transparent; vResizing: #shrinkWrap; layoutInset: 2; wrapCentering: #center; cellPositioning: #leftCenter. aCollectionOfMorphs do: [:each | row addMorphBack: each]. ^ row! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 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: 'ar 11/9/2000 20:37'! newVariableTransparentSpacer "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: Color transparent ! ! !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: '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! ! ColorMappingCanvas subclass: #AlphaBlendingCanvas instanceVariableNames: 'alpha' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Support'! !AlphaBlendingCanvas methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/1/2008 16:31'! 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. Do a blendAlpha if the rule is blend to cope with translucent images being drawn (via translucentImage:...)." 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. ]. rule = Form blend ifTrue:[ ^myCanvas image: aForm at: aPoint sourceRect: sourceRect rule: Form blendAlpha alpha: alpha. ].! ! !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: '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)! ! ImageMorph subclass: #AlphaImageMorph instanceVariableNames: 'alpha cachedForm layout scale enabled' classVariableNames: 'DefaultImage' poolDictionaries: '' category: 'Polymorph-Widgets'! !AlphaImageMorph commentStamp: 'gvc 5/18/2007 13:52' prior: 0! Displays an image with the specified alpha value (translucency) and optional scale and layout (scaled, top-right etc.).! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 9/26/2006 09:40'! alpha "Answer the value of alpha" ^ alpha! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 8/8/2007 15:34'! alpha: anObject "Set the value of alpha" alpha := anObject. self cachedForm: nil; changed; changed: #alpha! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 1/13/2009 17:58'! cachedForm "Answer the value of cachedForm" |form i effectiveAlpha| cachedForm ifNil: [ i := self image. self layout == #scaled ifTrue: [self extent = i extent ifFalse: [i := i magnify: i boundingBox by: (self extent / i extent) smoothing: 2]] ifFalse: [self scale ~= 1 ifTrue: [i := i magnify: i boundingBox by: self scale smoothing: 2]]. effectiveAlpha := self enabled ifTrue: [self alpha] ifFalse: [self alpha / 2]. effectiveAlpha = 1.0 ifTrue: [self cachedForm: i] ifFalse: [form := Form extent: i extent depth: 32. form fillColor: (Color white alpha: 0.003922). (form getCanvas asAlphaBlendingCanvas: effectiveAlpha) drawImage: i at: 0@0. self cachedForm: form]]. ^cachedForm! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 9/27/2006 15:02'! cachedForm: anObject "Set the value of cachedForm" cachedForm := anObject! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 1/13/2009 17:56'! enabled "Answer the value of enabled" ^enabled! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 1/13/2009 17:57'! enabled: anObject "Set the value of enabled" enabled := anObject. self cachedForm: nil; changed! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 9/28/2006 14:15'! image: anImage "Clear the cached form." ^self image: anImage size: anImage extent! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 8/27/2009 16:14'! image: aForm size: aPoint "Set the image to be the form scaled to the given size and padded if neccesary." |f f2| f := aForm scaledToSize: aPoint. (f depth < 32 and: [f depth > 4]) ifTrue: [f2 := Form extent: aPoint depth: 32. f2 fillColor: (Color white alpha: 0.003922). f2 getCanvas translucentImage: f at: 0@0. f2 fixAlpha] ifFalse: [f2 := f]. self cachedForm: nil. super image: f2. self extent: aPoint + (self borderWidth * 2). self changed: #imageExtent! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 6/30/2009 16:02'! imageExtent "Answer the extent of the original form." ^self image extent! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 10/11/2006 12:00'! layout "Answer the value of layout" ^ layout! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 8/8/2007 15:28'! layout: aSymbol "Set the value of layout" |old| (old := layout) = aSymbol ifTrue: [^self]. layout := aSymbol. (old = #scaled or: [aSymbol = #scaled]) ifTrue: [self cachedForm: nil]. self changed! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 8/8/2007 16:10'! layoutSymbols "Answer the available layout options." ^#(#center #tiled #scaled #topLeft #topCenter #topRight #rightCenter #bottomRight #bottomCenter #bottomLeft #leftCenter)! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 10/11/2006 12:43'! scale "Answer the value of scale" ^ scale! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 8/8/2007 15:34'! scale: aNumber "Set the value of scale" scale = aNumber ifTrue: [^self]. scale := aNumber. self cachedForm: nil; changed; changed: #scale! ! !AlphaImageMorph methodsFor: 'drawing' stamp: 'gvc 8/8/2007 16:25'! drawOn: aCanvas "Draw with the current alpha Can't do simple way since BitBlt rules are dodgy!!." aCanvas fillRectangle: self bounds fillStyle: self fillStyle borderStyle: self borderStyle. (self cachedForm width = 0 or: [self cachedForm height = 0]) ifTrue: [^self]. self layout == #tiled ifTrue: [aCanvas fillRectangle: self innerBounds fillStyle: (AlphaInfiniteForm with: self cachedForm)] ifFalse: [aCanvas clipBy: self innerBounds during: [:c | c translucentImage: self cachedForm at: self layoutPosition]]! ! !AlphaImageMorph methodsFor: 'geometry' stamp: 'gvc 10/11/2006 12:02'! extent: aPoint "Allow as normal." self perform: #extent: withArguments: {aPoint} inSuperclass: Morph ! ! !AlphaImageMorph methodsFor: 'geometry' stamp: 'gvc 8/8/2007 16:09'! layoutPosition "Answer the position that the cached form should be drawn based on the layout" self layout == #topCenter ifTrue: [^self innerBounds topCenter - (self cachedForm width // 2 @ 0)]. self layout == #topRight ifTrue: [^self innerBounds topRight - (self cachedForm width @ 0)]. self layout == #rightCenter ifTrue: [^self innerBounds rightCenter - (self cachedForm width @ (self cachedForm height // 2))]. self layout == #bottomRight ifTrue: [^self innerBounds bottomRight - self cachedForm extent]. self layout == #bottomCenter ifTrue: [^self innerBounds bottomCenter - (self cachedForm width // 2 @ self cachedForm height)]. self layout == #bottomLeft ifTrue: [^self innerBounds bottomLeft - (0 @ self cachedForm height)]. self layout == #leftCenter ifTrue: [^self innerBounds leftCenter - (0 @ (self cachedForm height // 2))]. self layout == #center ifTrue: [^self innerBounds center - (self cachedForm extent // 2)]. ^self innerBounds topLeft! ! !AlphaImageMorph methodsFor: 'geometry' stamp: 'gvc 10/22/2007 11:51'! optimalExtent "Answer the optimal extent for the receiver." ^self image extent * self scale + (self borderWidth * 2)! ! !AlphaImageMorph methodsFor: 'initialization' stamp: 'gvc 9/26/2006 12:40'! defaultColor "Answer the default color for the receiver." ^Color transparent! ! !AlphaImageMorph methodsFor: 'initialization' stamp: 'gvc 12/3/2007 11:37'! defaultImage "Answer the default image for the receiver." ^DefaultImage ifNil: [DefaultImage := DefaultForm asFormOfDepth: 32]! ! !AlphaImageMorph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:37'! initialize "Initialize the receiver. Use the 32 bit depth default image to avoid unnecessary conversions." super initialize. enabled := true. self scale: 1.0; layout: #topLeft; alpha: 1.0! ! InfiniteForm subclass: #AlphaInfiniteForm instanceVariableNames: 'origin extent' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-FillStyles'! !AlphaInfiniteForm commentStamp: 'gvc 5/18/2007 13:49' prior: 0! Alpha aware InfiniteForm.! !AlphaInfiniteForm methodsFor: 'accessing' stamp: 'gvc 10/7/2008 14:00'! extent "Answer the extent of the repeating area." ^extent ifNil: [SmallInteger maxVal @ SmallInteger maxVal]! ! !AlphaInfiniteForm methodsFor: 'accessing' stamp: 'gvc 10/3/2008 12:48'! extent: anObject "Set the value of extent" extent := anObject! ! !AlphaInfiniteForm methodsFor: 'accessing' stamp: 'gvc 10/3/2008 12:42'! origin "Answer the origin." ^origin ifNil: [0@0]! ! !AlphaInfiniteForm methodsFor: 'accessing' stamp: 'gvc 10/3/2008 12:42'! origin: aPoint "Set the origin." origin := aPoint! ! !AlphaInfiniteForm methodsFor: 'as yet unclassified' stamp: 'gvc 12/3/2008 17:09'! direction: aPoint "Ignore" ! ! !AlphaInfiniteForm methodsFor: 'displaying' stamp: 'gvc 10/7/2008 13:59'! computeBoundingBox "Refer to the comment in DisplayObject|computeBoundingBox." ^self origin extent: self extent! ! !AlphaInfiniteForm methodsFor: 'displaying' stamp: 'gvc 8/10/2009 11:42'! displayOnPort: aPort offsetBy: offset | targetBox patternBox savedMap top left | aPort destForm depth < 32 ifTrue: [^super displayOnPort: aPort offsetBy: offset]. "this version tries to get the form aligned where the user wants it and not just aligned with the cliprect" (patternForm isForm) ifFalse: [ "patternForm is a Pattern or Color; just use it as a mask for BitBlt" ^ aPort fill: aPort clipRect fillColor: patternForm rule: Form over]. "do it iteratively" targetBox := aPort clipRect. patternBox := patternForm boundingBox. savedMap := aPort colorMap. aPort sourceForm: patternForm; fillColor: nil; combinationRule: Form blend; sourceRect: (0@0 extent: patternBox extent); colorMap: (patternForm colormapIfNeededFor: aPort destForm). top := (targetBox top truncateTo: patternBox height) + offset y. left := (targetBox left truncateTo: patternBox width) + offset x. left to: (targetBox right - 1) by: patternBox width do: [:x | top to: (targetBox bottom - 1) by: patternBox height do: [:y | aPort destOrigin: x@y; copyBits]]. aPort colorMap: savedMap. ! ! GIFReadWriter subclass: #AnimatedGIFReadWriter instanceVariableNames: 'forms delays comments' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Files'! !AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 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) isNil ] 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' stamp: 'mir 11/19/2003 12:25'! comment: aString comments add: aString! ! !AnimatedGIFReadWriter methodsFor: 'private-decoding' stamp: 'mir 11/19/2003 12:21'! readBitData | form | form := super readBitData. form offset: offset. ^form! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AnimatedGIFReadWriter class instanceVariableNames: ''! !AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'lr 7/4/2009 10:42'! formsFromFileNamed: fileName | stream | stream := FileStream readOnlyFileNamed: fileName. ^ self formsFromStream: stream! ! !AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'lr 7/4/2009 10:42'! 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! ! Object subclass: #Announcement instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Core'! !Announcement methodsFor: '*announcements-view' stamp: 'lr 9/3/2006 16:17'! open self inspect! ! !Announcement methodsFor: 'converting' stamp: 'lr 10/3/2006 14:32'! asAnnouncement ^ self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Announcement class instanceVariableNames: ''! !Announcement class methodsFor: 'converting' stamp: 'lr 10/3/2006 14:31'! asAnnouncement ^ self new! ! !Announcement class methodsFor: 'public' stamp: 'lr 9/20/2006 08:18'! , anAnnouncementClass ^ AnnouncementSet with: self with: anAnnouncementClass! ! !Announcement class methodsFor: 'testing' stamp: 'lr 10/3/2006 14:31'! handles: anAnnouncementClass ^ anAnnouncementClass isKindOf: self! ! Announcement subclass: #AnnouncementMockA instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Announcements'! Announcement subclass: #AnnouncementMockB instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Announcements'! AnnouncementMockB subclass: #AnnouncementMockC instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Announcements'! Set subclass: #AnnouncementSet instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Core'! !AnnouncementSet methodsFor: 'adding' stamp: 'lr 6/13/2006 08:13'! , anAnnouncementClass self add: anAnnouncementClass! ! !AnnouncementSet methodsFor: 'testing' stamp: 'lr 10/3/2006 14:31'! handles: anAnnouncementClass ^ self anySatisfy: [ :each | each handles: anAnnouncementClass ]! ! Object subclass: #AnnouncementSpy instanceVariableNames: 'announcer announcements index' classVariableNames: '' poolDictionaries: '' category: 'Announcements-View'! !AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 6/14/2006 17:02'! announcements ^ announcements! ! !AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 9/3/2006 14:08'! announcements: aCollection announcements := aCollection. self changed: #announcements! ! !AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 6/14/2006 17:04'! announcer ^ announcer! ! !AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 9/25/2006 09:26'! announcer: anAnnouncer announcer ifNotNil: [ announcer unsubscribe: self ]. announcer := anAnnouncer. announcer ifNotNil: [ announcer subscribe: Announcement send: #announce: to: self ]! ! !AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 6/14/2006 17:02'! index ^ index ! ! !AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 6/14/2006 17:20'! index: anInteger index := anInteger. self changed: #index! ! !AnnouncementSpy methodsFor: 'accessing-dynamic' stamp: 'lr 9/3/2006 14:08'! extent ^ 250 @ 400! ! !AnnouncementSpy methodsFor: 'accessing-dynamic' stamp: 'lr 6/14/2006 17:03'! label ^ self announcer printString! ! !AnnouncementSpy methodsFor: 'actions' stamp: 'lr 9/3/2006 16:21'! clear self announcements: OrderedCollection new! ! !AnnouncementSpy methodsFor: 'actions' stamp: 'lr 9/25/2006 09:19'! close self announcer: nil! ! !AnnouncementSpy methodsFor: 'actions' stamp: 'lr 9/25/2006 09:25'! open (self announcements at: self index ifAbsent: [ ^ self ]) open! ! !AnnouncementSpy methodsFor: 'building' stamp: 'lr 9/3/2006 16:21'! buildMenu: aMenuMorph ^ aMenuMorph defaultTarget: self; add: 'open' action: #open; add: 'clear' action: #clear; yourself! ! !AnnouncementSpy methodsFor: 'building' stamp: 'lr 9/25/2006 09:20'! buildWith: aBuilder ^ aBuilder build: (aBuilder pluggableWindowSpec new model: self; label: self label; extent: self extent; closeAction: #close; children: (OrderedCollection new add: (aBuilder pluggableListSpec new model: self; list: #announcements; menu: #buildMenu:; getIndex: #index; setIndex: #index:; frame: (0 @ 0 corner: 1 @ 1); yourself); yourself); yourself)! ! !AnnouncementSpy methodsFor: 'initialization' stamp: 'lr 6/14/2006 17:03'! initialize super initialize. self announcements: OrderedCollection new. self index: 0! ! !AnnouncementSpy methodsFor: 'private' stamp: 'lr 9/3/2006 14:09'! announce: anAnnouncement self announcements add: anAnnouncement. self index: self announcements size. self changed: #announcements! ! !AnnouncementSpy methodsFor: 'private' stamp: 'lr 6/14/2006 17:19'! changed: aSymbol WorldState addDeferredUIMessage: [ super changed: aSymbol ]! ! !AnnouncementSpy methodsFor: 'private' stamp: 'lr 6/14/2006 17:29'! perform: selector orSendTo: otherTarget ^ (self respondsTo: selector) ifTrue: [ self perform: selector ] ifFalse: [ super perform: selector orSendTo: otherTarget ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AnnouncementSpy class instanceVariableNames: ''! !AnnouncementSpy class methodsFor: 'instance-creation' stamp: 'lr 6/14/2006 17:05'! on: anAnnouncer ^ self new announcer: anAnnouncer; yourself! ! !AnnouncementSpy class methodsFor: 'instance-creation' stamp: 'lr 6/14/2006 17:05'! openOn: anAnnouncer ToolBuilder open: (self on: anAnnouncer)! ! Object subclass: #Announcer instanceVariableNames: 'subscriptions' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Core'! !Announcer commentStamp: 'lr 3/2/2009 10:27' prior: 0! The code is based on the announcements as described by Vassili Bykov in . The implementation is a slightly extended and generalized version of the code found in OmniBrowser by Colin Putney.! !Announcer methodsFor: '*announcements-view' stamp: 'lr 9/20/2006 08:18'! open AnnouncementSpy openOn: self! ! !Announcer methodsFor: 'announce' stamp: 'lr 8/5/2008 12:06'! announce: anAnnouncement | announcement | announcement := anAnnouncement asAnnouncement. subscriptions ifNil: [ ^ announcement ]. subscriptions keysAndValuesDo: [ :class :actions | (class handles: announcement) ifTrue: [ actions valueWithArguments: (Array with: announcement) ] ]. ^ announcement! ! !Announcer methodsFor: 'convenience' stamp: 'lr 10/27/2006 14:26'! on: anAnnouncementClass do: aValuable ^ self subscribe: anAnnouncementClass do: aValuable! ! !Announcer methodsFor: 'convenience' stamp: 'lr 10/27/2006 14:27'! on: anAnnouncementClass send: aSelector to: anObject ^ self subscribe: anAnnouncementClass send: aSelector to: anObject! ! !Announcer methodsFor: 'convenience' stamp: 'tg 2/25/2009 12:05'! when: anAnnouncementClass do: aValuable ^ self subscribe: anAnnouncementClass do: aValuable! ! !Announcer methodsFor: 'subscription' stamp: 'lr 8/5/2008 12:05'! subscribe: anAnnouncementClass do: aValuable | actions | subscriptions ifNil: [ subscriptions := IdentityDictionary new ]. actions := subscriptions at: anAnnouncementClass ifAbsent: [ ActionSequence new ]. subscriptions at: anAnnouncementClass put: (actions copyWith: aValuable). ^ aValuable! ! !Announcer methodsFor: 'subscription' stamp: 'lr 10/27/2006 14:27'! subscribe: anAnnouncementClass send: aSelector to: anObject ^ self subscribe: anAnnouncementClass do: (MessageSend receiver: anObject selector: aSelector)! ! !Announcer methodsFor: 'subscription' stamp: 'lr 8/5/2008 12:05'! unsubscribe: anObject subscriptions ifNil: [ ^ self ]. subscriptions keysAndValuesDo: [ :class :actions | subscriptions at: class put: (actions reject: [ :each | each receiver == anObject ]) ]. subscriptions keysAndValuesRemove: [ :class :actions | actions isEmpty ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Announcer class instanceVariableNames: ''! TestCase subclass: #AnnouncerTest instanceVariableNames: 'announcer' classVariableNames: '' poolDictionaries: '' category: 'Tests-Announcements'! !AnnouncerTest methodsFor: 'running' stamp: 'lr 9/25/2006 08:42'! setUp announcer := Announcer new! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:11'! testAnnounceClass self assert: (announcer announce: AnnouncementMockA) class = AnnouncementMockA! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:10'! testAnnounceInstance | instance | instance := AnnouncementMockA new. self assert: (announcer announce: instance) = instance! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:08'! testSubscribeBlock | announcement instance | announcer subscribe: AnnouncementMockA do: [ :ann | announcement := ann ]. announcement := nil. instance := announcer announce: AnnouncementMockA. self assert: announcement = instance. announcement := nil. instance := announcer announce: AnnouncementMockB. self assert: announcement isNil! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:07'! testSubscribeSend | announcement instance | announcer subscribe: AnnouncementMockA send: #value: to: [ :ann | announcement := ann ]. announcement := nil. instance := announcer announce: AnnouncementMockA. self assert: announcement = instance. announcement := nil. instance := announcer announce: AnnouncementMockB new. self assert: announcement isNil! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:07'! testSubscribeSet | announcement instance | announcer subscribe: AnnouncementMockA , AnnouncementMockC do: [ :ann | announcement := ann ]. announcement := nil. instance := announcer announce: AnnouncementMockA. self assert: announcement = instance. announcement := nil. instance := announcer announce: AnnouncementMockB. self assert: announcement isNil. announcement := nil. instance := announcer announce: AnnouncementMockC. self assert: announcement = instance! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:06'! testSubscribeSubclass | announcement instance | announcer subscribe: AnnouncementMockB do: [ :ann | announcement := ann ]. announcement := nil. instance := announcer announce: AnnouncementMockA. self assert: announcement isNil. announcement := nil. instance := announcer announce: AnnouncementMockB. self assert: announcement = instance. announcement := nil. instance := announcer announce: AnnouncementMockC. self assert: announcement = instance.! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 9/25/2006 09:10'! testUnsubscribeBlock | announcement | announcer subscribe: AnnouncementMockA do: [ :ann | announcement := ann ]. announcer unsubscribe: self. announcement := nil. announcer announce: AnnouncementMockA new. self assert: announcement isNil! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 9/25/2006 09:13'! testUnsubscribeSend | announcement receiver | announcer subscribe: AnnouncementMockA send: #value: to: (receiver := [ :ann | announcement := ann ]). announcer unsubscribe: receiver. announcement := nil. announcer announce: AnnouncementMockA new. self assert: announcement isNil! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 9/25/2006 09:13'! testUnsubscribeSet | announcement | announcer subscribe: AnnouncementMockA , AnnouncementMockB do: [ :ann | announcement := ann ]. announcer unsubscribe: self. announcement := nil. announcer announce: AnnouncementMockA new. self assert: announcement isNil. announcement := nil. announcer announce: AnnouncementMockB new. self assert: announcement isNil.! ! 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: 'notes' 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: 'alain.plantec 2/8/2009 21:37'! askForDefault "self askForDefault" self registeredClasses isEmpty ifTrue: [self inform: 'There are no ', self appName, ' applications registered.'. ^ default := nil]. self registeredClasses size = 1 ifTrue: [^ default := self registeredClasses anyOne]. default := UIManager default chooseFrom: (self registeredClasses collect: [:c | c name]) values: self registeredClasses title: ('Which ' , self appName, ' would you prefer?') translated. 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: 'ar 9/27/2005 21:48'! removeObsolete "AppRegistry removeObsoleteClasses" self registeredClasses copy do:[:cls| (cls class isObsolete or:[cls isBehavior and:[cls isObsolete]]) ifTrue:[self unregister: cls]]. self subclasses do:[:cls| cls removeObsolete].! ! !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: [].! ! Path subclass: #Arc instanceVariableNames: 'quadrant radius center' classVariableNames: '' poolDictionaries: '' category: 'ST80-Paths'! !Arc commentStamp: '' 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: 'Compression-Archives'! !Archive commentStamp: '' 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: 'eem 6/11/2008 12:47'! addTree: aFileNameOrDirectory removingFirstCharacters: n match: aBlock | dir 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 newMember | 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: 'stephane.ducasse 8/8/2009 12:32'! 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 ] ensure: [ stream close ]! ! !Archive methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:39'! initialize super 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: 'Compression-Archives'! !ArchiveMember commentStamp: '' 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: 'initialization' stamp: 'ar 3/2/2001 18:46'! close ! ! !ArchiveMember methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:39'! initialize super 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 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 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! ! Error subclass: #ArithmeticError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! ArrayedCollection variableSubclass: #Array instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Arrayed'! !Array commentStamp: '' prior: 0! I present an ArrayedCollection whose elements are objects.! !Array methodsFor: 'accessing' stamp: 'ar 8/26/2001 22:02'! atWrap: index "Optimized to go through the primitive if possible" ^ 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" ^ 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: 'eem 6/11/2008 12:49'! preMultiplyByMatrix: m "Answer m+*self where m is a Matrix." m columnCount = self size ifFalse: [self error: 'dimensions do not conform']. ^(1 to: m rowCount) collect: [:row | | s | s := 0. 1 to: self size do: [:k | s := (m at: row at: k) * (self at: k) + s]. s]! ! !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." 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." 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." self primitiveFailed! ! !Array methodsFor: 'converting' stamp: 'nice 4/16/2009 09:35'! 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" ^ self collect: [:each | | item | item := each. (each isString and: [each isSymbol not]) ifTrue: [ item := Compiler evaluate: each]. each class == Array ifTrue: [item := item evalStrings]. item]! ! !Array methodsFor: 'copying' stamp: 'ar 2/11/2001 01:55'! copyWithDependent: newElement self size = 0 ifTrue:[^DependentsArray with: newElement]. ^self copyWith: newElement! ! !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: '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: 'printing' stamp: 'sd 7/31/2005 21:44'! printOn: aStream self isLiteral ifTrue: [self printAsLiteralFormOn: aStream. ^ self]. self isSelfEvaluating ifTrue: [self printAsSelfEvaluatingFormOn: aStream. ^ self]. super printOn: 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: 'self evaluating' stamp: 'sd 7/31/2005 21:44'! isSelfEvaluating ^ (self allSatisfy: [:each | each isSelfEvaluating]) and: [self class == Array]! ! !Array methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:44'! printAsLiteralFormOn: aStream aStream nextPut: $#. self printElementsOn: aStream ! ! !Array methodsFor: 'self evaluating' stamp: 'MarcusDenker 10/5/2009 11:44'! printAsSelfEvaluatingFormOn: aStream aStream nextPut: ${. self do: [:el | aStream print: el] separatedBy: [ aStream nextPutAll: '. ']. aStream nextPut: $}! ! !Array methodsFor: 'testing' stamp: 'eem 5/8/2008 11:13'! isArray ^true! ! !Array methodsFor: 'testing' stamp: 'sma 5/12/2000 14:11'! isLiteral ^ self allSatisfy: [:each | each isLiteral]! ! !Array methodsFor: 'private' stamp: 'marcus.denker 9/28/2008 09:57'! 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:" 1 to: self size do: [:index | | lit | (lit := self at: index) == literal ifTrue: [^ true]. (lit class == Array and: [lit hasLiteral: literal]) ifTrue: [^ true]]. ^ false! ! !Array methodsFor: 'private' stamp: 'md 3/1/2006 21:09'! hasLiteralSuchThat: testBlock "Answer true if testBlock returns true for any literal in this array, even if imbedded in further Arrays or CompiledMethods. This method is only intended for private use by CompiledMethod hasLiteralSuchThat:" | lit | 1 to: self size do: [:index | (testBlock value: (lit := self at: index)) ifTrue: [^ true]. (lit hasLiteralSuchThat: testBlock) ifTrue: [^ true]]. ^ false! ! !Array methodsFor: 'private' stamp: 'G.C 10/22/2008 09:59'! refersToLiteral: literal "Answer true if literal is identical to any literal in this array, even if imbedded in further array structures or closure methods" 1 to: self size do: [ :index | | lit | (lit := self at: index) == literal ifTrue: [ ^ true ]. (lit refersToLiteral: literal) 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." super replaceFrom: start to: stop with: replacement startingAt: repStart! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Array class instanceVariableNames: ''! !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'! 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: '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: '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" "This method runs primitively if successful" ^ self basicNew: sizeRequested "Exceptional conditions will be handled in basicNew:" ! ! TestCase subclass: #ArrayLiteralTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Compiler'! !ArrayLiteralTest methodsFor: 'initialization' stamp: 'avi 2/16/2004 21:09'! tearDown self class removeSelector: #array! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:34'! testByteArrayBase self class compile: 'array ^ #[2r1010 8r333 16rFF]'. self assert: (self array isKindOf: ByteArray). self assert: (self array size = 3). self assert: (self array first = 10). self assert: (self array second = 219). self assert: (self array last = 255) ! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:35'! testByteArrayEmpty self class compile: 'array ^ #[]'. self assert: (self array isKindOf: ByteArray). self assert: (self array isEmpty)! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:36'! testByteArrayLiteral self class compile: 'array ^ #[ 1 2 3 4 ]'. self assert: (self array = self array). self assert: (self array == self array)! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:45'! testByteArrayLong self class compile: 'array ^ #[ ' , ((0 to: 255) inject: ' ' into: [ :r :e | r , ' ' , e asString ]) , ' ]'. self assert: (self array isKindOf: ByteArray). self assert: (self array size = 256). 0 to: 255 do: [ :index | self assert: (self array at: index + 1) = index ]! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:32'! testByteArrayRange self class compile: 'array ^ #[ 0 255 ]'. self assert: (self array isKindOf: ByteArray). self assert: (self array size = 2). self assert: (self array first = 0). self assert: (self array last = 255)! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'Henrik Sperre Johansen 3/23/2009 13:55'! testByteArrayWithinArray self class compile: 'array ^ #( #[1] #[2] )'. self assert: (self array isKindOf: Array). self assert: (self array size = 2). self assert: (self array first isKindOf: ByteArray). self assert: (self array first first = 1). self assert: (self array last isKindOf: ByteArray). self assert: (self array last first = 2) ! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'avi 2/16/2004 21:08'! testReservedIdentifiers self class compile: 'array ^ #(nil true false)'. self assert: self array = {nil. true. false}.! ! !ArrayLiteralTest methodsFor: 'tests' 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}.! ! CollectionRootTest subclass: #ArrayTest uses: TEmptySequenceableTest + TSequencedElementAccessTest + TCloneTest + TIncludesWithIdentityCheckTest + TCopyTest + TSetArithmetic + TCreationWithTest + TPutBasicTest + TConvertTest - {} + TSortTest + TOccurrencesForMultiplinessTest + TIterateSequencedReadableTest + TSequencedConcatenationTest + TReplacementSequencedTest + TAsStringCommaAndDelimiterSequenceableTest + TBeginsEndsWith + TPrintOnSequencedTest + TIndexAccess + TSubCollectionAccess + TConvertAsSetForMultiplinessIdentityTest + TCopyPartOfSequenceable + TCopySequenceableSameContents + TCopySequenceableWithOrWithoutSpecificElements + TCopySequenceableWithReplacement + TIndexAccessForMultipliness + TCopyPartOfSequenceableForMultipliness + TConvertAsSortedTest + TPutTest + TSequencedStructuralEqualityTest instanceVariableNames: 'example1 literalArray selfEvaluatingArray otherArray nonSEArray1 nonSEarray2 example2 empty collection result withoutEqualElements withEqualElements withCharacters unsortedCollection sortedInAscendingOrderCollection sizeCollection collectionNotIncluded removedCollection elementInForCopy elementNotInForCopy firstIndex secondIndex replacementCollection indexArray valueArray nonEmptyMoreThan1Element subCollectionNotIn replacementCollectionSameSize oldSubCollection nonEmpty1Element collectionOfCollection collectionOfFloatWithEqualElements floatCollectionWithSameBeginingAnEnd collectionWithoutNil duplicateElement collection5Elements' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Arrayed'! !ArrayTest commentStamp: '' 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: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:12'! aValue ^ 33! ! !ArrayTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:13'! anIndex ^ 2! ! !ArrayTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:19'! anotherValue ^ 66! ! !ArrayTest methodsFor: 'initialization' stamp: 'stephane.ducasse 10/6/2008 16:53'! collection ^ collection ! ! !ArrayTest methodsFor: 'initialization' stamp: 'stephane.ducasse 10/5/2008 15:06'! empty ^ empty! ! !ArrayTest methodsFor: 'initialization' stamp: 'stephane.ducasse 10/5/2008 15:06'! nonEmpty ^ example1! ! !ArrayTest methodsFor: 'initialization' stamp: 'stephane.ducasse 10/6/2008 16:54'! result ^ result! ! !ArrayTest methodsFor: 'initialization' stamp: 'delaunay 5/14/2009 14:00'! setUp literalArray := #(1 true 3 #four). selfEvaluatingArray := { 1. true. (3/4). Color black. (2 to: 4) . 5 }. nonSEArray1 := { 1 . Set with: 1 }. nonSEarray2 := { Smalltalk associationAt: #Array }. example1 := #(1 2 3 4 5) copy. indexArray:= {2. 3. 4.}. valueArray:={0. 0. 0.}. oldSubCollection:= {2. 3. 4.}. nonEmptyMoreThan1Element:= example1. subCollectionNotIn:= {1. 8. 3.}. collectionNotIncluded:= {7. 8. 9.}. removedCollection:= { 2. 4. }. example2 := {1. 2. 3/4. 4. 5}. collection := #(1 -2 3 1). collectionWithoutNil := #( 1 2 3 4). result := {SmallInteger. SmallInteger. SmallInteger. SmallInteger.}. empty := #(). duplicateElement := 5.2. withEqualElements := {1.5. duplicateElement . 6.1. 2.0. duplicateElement .} . withoutEqualElements := {1.1. 4.4. 6.5. 2.4. 3.1.}. withCharacters := {$a. $x. $d. $c. $m.}. unsortedCollection := {1. 2. 8. 5. 6. 7.}. sortedInAscendingOrderCollection := {1. 2. 3. 4. 5. 6.}. elementInForCopy:= 2. elementNotInForCopy:= 9. firstIndex:= 2. secondIndex:= 4. replacementCollection:= {4. 3. 2. 1.}. replacementCollectionSameSize := {5. 4. 3.}. nonEmpty1Element:={ 5.}. collectionOfCollection:={1.5. 5.5. 6.5.}. collectionOfFloatWithEqualElements:={1.5. 5.5. 6.5. 1.5}. floatCollectionWithSameBeginingAnEnd := {1.5. 5.5. 1.5 copy}. collection5Elements := { 1. 2. 5. 3. 4.}.! ! !ArrayTest methodsFor: 'parameters'! accessValuePutIn "return access the element put in the non-empty collection" ^ self perform: self selectorToAccessValuePutIn! ! !ArrayTest methodsFor: 'parameters'! accessValuePutInOn: s "return access the element put in the non-empty collection" ^ s perform: self selectorToAccessValuePutIn! ! !ArrayTest methodsFor: 'parameters' stamp: 'stephane.ducasse 10/5/2008 15:12'! selectorToAccessValuePutIn "return the selector of the method that should be invoked to access an element" ^ #second! ! !ArrayTest methodsFor: 'parameters' stamp: 'stephane.ducasse 10/9/2008 18:49'! valuePutIn "the value that we will put in the non empty collection" ^ 2! ! !ArrayTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/30/2008 19:02'! accessCollection ^ example1! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 14:45'! anotherElementNotIn ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:05'! anotherElementOrAssociationIn " return an element (or an association for Dictionary ) present in 'collection' " ^ self collection anyOne.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:05'! anotherElementOrAssociationNotIn " return an element (or an association for Dictionary )not present in 'collection' " ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/9/2009 11:11'! collectionInForIncluding ^ self nonEmpty copyWithoutFirst.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 15:16'! collectionMoreThan1NoDuplicates " return a collection of size 5 without equal elements" ^ withoutEqualElements ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:01'! collectionMoreThan5Elements " return a collection including at least 5 elements" ^ collection5Elements ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/30/2009 10:51'! collectionNotIncluded ^ collectionNotIncluded.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:07'! collectionOfFloat ^ collectionOfCollection! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 10:28'! collectionWith1TimeSubcollection ^ (self oldSubCollection copyWithoutFirst),self oldSubCollection,(self oldSubCollection copyWithoutFirst). ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 10:29'! collectionWith2TimeSubcollection ^ (self oldSubCollection copyWithoutFirst),self oldSubCollection,(self oldSubCollection copyWithoutFirst),self oldSubCollection .! ! !ArrayTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/26/2009 09:58'! collectionWithCharacters ^ withCharacters.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 13:49'! collectionWithCopy "return a collection of type 'self collectionWIithoutEqualsElements clas' containing no elements equals ( with identity equality) but 2 elements only equals with classic equality" | result collection | collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements. collection add: collection first copy. result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection. ^ result! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 10:22'! collectionWithCopyNonIdentical " return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)" ^ collectionOfCollection! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:24'! collectionWithElementsToRemove ^ removedCollection! ! !ArrayTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/26/2009 09:57'! collectionWithEqualElements ^ withEqualElements.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 13:50'! collectionWithIdentical "return a collection of type : 'self collectionWIithoutEqualsElements class containing two elements equals ( with identity equality)" | result collection element | collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements. element := collection first. collection add: element. result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection. ^ result! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 14:17'! collectionWithNonIdentitySameAtEndAndBegining " return a collection with elements at end and begining equals only with classic equality (they are not the same object). (others elements of the collection are not equal to those elements)" ^ floatCollectionWithSameBeginingAnEnd ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 11:15'! collectionWithSameAtEndAndBegining " return a collection with elements at end and begining equals . (others elements of the collection are not equal to those elements)" ^ floatCollectionWithSameBeginingAnEnd ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 10:27'! collectionWithSortableElements " return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" ^ withoutEqualElements ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 10:25'! collectionWithoutEqualElements ^ withoutEqualElements .! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/16/2009 15:49'! collectionWithoutEqualsElements ^ withoutEqualElements ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 11:39'! collectionWithoutNilElements " return a collection that doesn't includes a nil element and that doesn't includes equal elements'" ^ collectionWithoutNil ! ! !ArrayTest methodsFor: 'requirements' stamp: 'damienpollet 1/30/2009 17:27'! element ^ 3! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:22'! elementInCollectionOfFloat ^ collectionOfCollection atRandom! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:28'! elementInForCopy ^ elementInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:39'! elementInForElementAccessing " return an element inculded in 'accessCollection '" ^ self accessCollection anyOne! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 13:55'! elementInForIncludesTest ^ elementInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/10/2009 14:49'! elementInForIndexAccess ^ elementInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 15:18'! elementInForIndexAccessing ^ withoutEqualElements anyOne! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 11:54'! elementInForOccurrences ^ elementInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/6/2009 10:16'! elementInForReplacement ^ elementInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 14:45'! elementNotIn "return an element not included in 'nonEmpty' " ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:29'! elementNotInForCopy ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:39'! elementNotInForElementAccessing " return an element not included in 'accessCollection' " ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/7/2009 11:18'! elementNotInForIndexAccessing ^elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 14:45'! elementNotInForOccurrences ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 16:13'! elementTwiceInForOccurrences " return an element included exactly two time in # collectionWithEqualElements" ^ duplicateElement ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 13:46'! elementsCopyNonIdenticalWithoutEqualElements " return a collection that does niot include equal elements ( classic equality )" ^ collectionOfCollection! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 16:41'! firstCollection ^example1 ! ! !ArrayTest methodsFor: 'requirements' stamp: 'damiencassou 1/27/2009 10:35'! firstEven "Returns the first even number of #collection" ^ -2! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:29'! firstIndex ^ firstIndex ! ! !ArrayTest methodsFor: 'requirements' stamp: 'damiencassou 1/27/2009 10:35'! firstOdd "Returns the first odd number of #collection" ^ 1! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 14:00'! floatCollectionWithSameAtEndAndBegining " return a collection with elements at end and begining equals only with classic equality (they are not the same object). (others elements of the collection are not equal to those elements)" ^ floatCollectionWithSameBeginingAnEnd ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 16:00'! indexArray ^ indexArray .! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/16/2009 15:59'! indexInForCollectionWithoutDuplicates ^ 2.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/16/2009 16:56'! indexInNonEmpty ^ 2 ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/9/2009 15:53'! integerCollection ^example1 .! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 10:28'! integerCollectionWithoutEqualElements ^{1. 2. 6. 5.}! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:53'! moreThan3Elements " return a collection including atLeast 3 elements" ^ example1 ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:53'! moreThan4Elements " return a collection including at leat 4 elements" ^ example1 ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/6/2009 10:16'! newElement ^999! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/8/2009 11:40'! nonEmpty1Element ^ nonEmpty1Element ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 15:20'! nonEmptyMoreThan1Element ^nonEmptyMoreThan1Element .! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/6/2009 11:41'! oldSubCollection ^oldSubCollection ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:29'! replacementCollection ^replacementCollection .! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/6/2009 10:32'! replacementCollectionSameSize ^replacementCollectionSameSize ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 11:29'! resultForCollectElementsClass " return the retsult expected by collecting the class of each element of collectionWithoutNilElements" ^ result ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 16:41'! secondCollection ^example2 ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:29'! secondIndex ^ secondIndex ! ! !ArrayTest methodsFor: 'requirements' stamp: 'damienpollet 1/13/2009 16:59'! sizeCollection ^ self collection! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 14:08'! smallerIndex ^ firstIndex -1! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/27/2009 15:20'! sortedInAscendingOrderCollection ^sortedInAscendingOrderCollection . ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/3/2009 11:35'! subCollectionNotIn ^subCollectionNotIn ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/27/2009 15:20'! unsortedCollection ^unsortedCollection .! ! !ArrayTest methodsFor: 'requirements'! valueArray " return a collection (with the same size than 'indexArray' )of values to be put in 'nonEmpty' at indexes in 'indexArray' " | result | result := Array new: self indexArray size. 1 to: result size do: [:i | result at:i put: (self aValue ). ]. ^ result.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 14:11'! withEqualElements " return a collection of float including equal elements (classic equality)" ^ collectionOfFloatWithEqualElements! ! !ArrayTest methodsFor: 'test - copy' stamp: 'delaunay 4/17/2009 15:26'! elementToAdd ^ 55! ! !ArrayTest methodsFor: 'test - creation' stamp: 'stephane.ducasse 12/9/2008 22:00'! collectionClass ^ Array! ! !ArrayTest methodsFor: 'test - creation'! testOfSize "self debug: #testOfSize" | aCol | aCol := self collectionClass ofSize: 3. self assert: (aCol size = 3). ! ! !ArrayTest methodsFor: 'test - creation'! testWith "self debug: #testWith" | aCol element | element := self collectionMoreThan5Elements anyOne. aCol := self collectionClass with: element. self assert: (aCol includes: element).! ! !ArrayTest methodsFor: 'test - creation'! testWithAll "self debug: #testWithAll" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection . aCol := self collectionClass withAll: collection . collection do: [ :each | self assert: (aCol occurrencesOf: each ) = ( collection occurrencesOf: each ) ]. self assert: (aCol size = collection size ).! ! !ArrayTest methodsFor: 'test - creation'! testWithWith "self debug: #testWithWith" | aCol collection element1 element2 | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 2 . element1 := collection at: 1. element2 := collection at:2. aCol := self collectionClass with: element1 with: element2 . self assert: (aCol occurrencesOf: element1 ) == ( collection occurrencesOf: element1). self assert: (aCol occurrencesOf: element2 ) == ( collection occurrencesOf: element2). ! ! !ArrayTest methodsFor: 'test - creation'! testWithWithWith "self debug: #testWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom:1 to: 3 . aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !ArrayTest methodsFor: 'test - creation'! testWithWithWithWith "self debug: #testWithWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 4. aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: ( collection at: 4). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !ArrayTest methodsFor: 'test - creation'! testWithWithWithWithWith "self debug: #testWithWithWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 5 . aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: (collection at: 4 ) with: ( collection at: 5 ). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !ArrayTest methodsFor: 'test - equality'! testEqualSign "self debug: #testEqualSign" self deny: (self empty = self nonEmpty).! ! !ArrayTest methodsFor: 'test - equality'! testEqualSignIsTrueForNonIdenticalButEqualCollections "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" self assert: (self empty = self empty copy). self assert: (self empty copy = self empty). self assert: (self empty copy = self empty copy). self assert: (self nonEmpty = self nonEmpty copy). self assert: (self nonEmpty copy = self nonEmpty). self assert: (self nonEmpty copy = self nonEmpty copy).! ! !ArrayTest methodsFor: 'test - equality'! testEqualSignOfIdenticalCollectionObjects "self debug: #testEqualSignOfIdenticalCollectionObjects" self assert: (self empty = self empty). self assert: (self nonEmpty = self nonEmpty). ! ! !ArrayTest methodsFor: 'test - iterate' stamp: 'luc.fabresse 11/29/2008 23:10'! expectedSizeAfterReject ^1! ! !ArrayTest methodsFor: 'test - iterate' stamp: 'stephane.ducasse 10/6/2008 17:39'! speciesClass ^ Array! ! !ArrayTest methodsFor: 'test - iterate' stamp: 'damienpollet 1/13/2009 16:28'! testAnySatisfy self assert: ( self collection anySatisfy: [:each | each = -2]). self deny: (self collection anySatisfy: [:each | each isString]).! ! !ArrayTest methodsFor: 'test - iterate' stamp: 'delaunay 4/14/2009 14:12'! testDo | res | res := OrderedCollection new. self collection do: [:each | res add: each class]. self assert: res asArray = self result.! ! !ArrayTest methodsFor: 'test - iterate' stamp: 'delaunay 4/14/2009 14:13'! testDo2 | res | res := OrderedCollection new. self collection do: [:each | res add: each class]. self assert: res asArray = self result. ! ! !ArrayTest methodsFor: 'testing' stamp: 'zz 12/5/2005 17:12'! testIsArray self assert: example1 isArray! ! !ArrayTest methodsFor: 'testing' stamp: 'apb 4/21/2006 08:59'! testIsLiteral "We work with a copy of literalArray, to avoid corrupting the code." | l | l := literalArray copy. self assert: l isLiteral. l at: 1 put: self class. self deny: l isLiteral! ! !ArrayTest methodsFor: 'testing' stamp: 'zz 12/5/2005 17:18'! testIsSelfEvaluating self assert: example1 isSelfEvaluating. example1 at: 1 put: Bag new. self deny: example1 isSelfEvaluating. example1 at: 1 put: 1.! ! !ArrayTest methodsFor: 'testing' stamp: 'zz 12/5/2005 17:50'! testLiteralEqual self deny: (example1 literalEqual: example1 asIntegerArray)! ! !ArrayTest methodsFor: 'testing' stamp: 'dc 5/24/2007 10:56'! testNewWithSize |array| array := Array new: 5. self assert: array size = 5. 1 to: 5 do: [:index | self assert: (array at: index) isNil]! ! !ArrayTest methodsFor: 'testing' stamp: 'stephane.ducasse 10/6/2008 16:53'! testPremultiply self assert: example1 +* #(2 ) = #(2 4 6 8 10 ) ! ! !ArrayTest methodsFor: 'testing' stamp: 'delaunay 5/4/2009 15:15'! testPrinting self assert: literalArray printString = '#(1 true 3 #four)'. self assert: (literalArray = (Compiler evaluate: literalArray printString)). "self assert: selfEvaluatingArray printString = '{1. true. (3/4). Color black. (2 to: 4). 5}'." self assert: (selfEvaluatingArray = (Compiler evaluate: selfEvaluatingArray printString)). self assert: nonSEArray1 printString = 'an Array(1 a Set(1))'. self assert: nonSEarray2 printString = '{#Array->Array}' ! ! !ArrayTest methodsFor: 'tests - accessing' stamp: 'delaunay 4/10/2009 16:19'! testAtWrap2 | tabTest | tabTest := #(5 6 8 ). self assert: (tabTest atWrap: 2) = 6. self assert: (tabTest atWrap: 7) = 5. self assert: (tabTest atWrap: 5) = 6. self assert: (tabTest atWrap: 0) = 8. self assert: (tabTest atWrap: 1) = 5. self assert: (tabTest atWrap: -2) = 5! ! !ArrayTest methodsFor: 'tests - as identity set'! testAsIdentitySetWithIdentityEqualsElements | result | result := self collectionWithIdentical asIdentitySet. " Only one element should have been removed as two elements are equals with Identity equality" self assert: result size = (self collectionWithIdentical size - 1). self collectionWithIdentical do: [ :each | (self collectionWithIdentical occurrencesOf: each) > 1 ifTrue: [ "the two elements equals only with classic equality shouldn't 'have been removed" self assert: (result asOrderedCollection occurrencesOf: each) = 1 " the other elements are still here" ] ifFalse: [ self assert: (result asOrderedCollection occurrencesOf: each) = 1 ] ]. self assert: result class = IdentitySet! ! !ArrayTest methodsFor: 'tests - as identity set'! testAsIdentitySetWithoutIdentityEqualsElements | result collection | collection := self collectionWithCopy. result := collection asIdentitySet. " no elements should have been removed as no elements are equels with Identity equality" self assert: result size = collection size. collection do: [ :each | (collection occurrencesOf: each) = (result asOrderedCollection occurrencesOf: each) ]. self assert: result class = IdentitySet! ! !ArrayTest methodsFor: 'tests - as set tests'! testAsIdentitySetWithEqualsElements | result collection | collection := self withEqualElements . result := collection asIdentitySet. collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. self assert: result class = IdentitySet.! ! !ArrayTest methodsFor: 'tests - as set tests'! testAsSetWithEqualsElements | result | result := self withEqualElements asSet. self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. self assert: result class = Set! ! !ArrayTest methodsFor: 'tests - as sorted collection'! testAsSortedArray | result collection | collection := self collectionWithSortableElements . result := collection asSortedArray. self assert: (result class includesBehavior: Array). self assert: result isSorted. self assert: result size = collection size! ! !ArrayTest methodsFor: 'tests - as sorted collection'! testAsSortedCollection | aCollection result | aCollection := self collectionWithSortableElements . result := aCollection asSortedCollection. self assert: (result class includesBehavior: SortedCollection). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = aCollection size.! ! !ArrayTest methodsFor: 'tests - as sorted collection'! testAsSortedCollectionWithSortBlock | result tmp | result := self collectionWithSortableElements asSortedCollection: [:a :b | a > b]. self assert: (result class includesBehavior: SortedCollection). result do: [ :each | self assert: (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = self collectionWithSortableElements size. tmp:=result at: 1. result do: [:each| self assert: tmp>=each. tmp:=each]. ! ! !ArrayTest methodsFor: 'tests - at put'! testAtPut "self debug: #testAtPut" self nonEmpty at: self anIndex put: self aValue. self assert: (self nonEmpty at: self anIndex) = self aValue. ! ! !ArrayTest methodsFor: 'tests - at put'! testAtPutOutOfBounds "self debug: #testAtPutOutOfBounds" self should: [self empty at: self anIndex put: self aValue] raise: Error ! ! !ArrayTest methodsFor: 'tests - at put'! testAtPutTwoValues "self debug: #testAtPutTwoValues" self nonEmpty at: self anIndex put: self aValue. self nonEmpty at: self anIndex put: self anotherValue. self assert: (self nonEmpty at: self anIndex) = self anotherValue.! ! !ArrayTest methodsFor: 'tests - begins ends with'! testsBeginsWith self assert: (self nonEmpty beginsWith:(self nonEmpty copyUpTo: self nonEmpty size)). self assert: (self nonEmpty beginsWith:(self nonEmpty )). self deny: (self nonEmpty beginsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! !ArrayTest methodsFor: 'tests - begins ends with'! testsBeginsWithEmpty self deny: (self nonEmpty beginsWith:(self empty)). self deny: (self empty beginsWith:(self nonEmpty )). ! ! !ArrayTest methodsFor: 'tests - begins ends with'! testsEndsWith self assert: (self nonEmpty endsWith:(self nonEmpty copyWithoutFirst)). self assert: (self nonEmpty endsWith:(self nonEmpty )). self deny: (self nonEmpty endsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! !ArrayTest methodsFor: 'tests - begins ends with'! testsEndsWithEmpty self deny: (self nonEmpty endsWith:(self empty )). self deny: (self empty endsWith:(self nonEmpty )). ! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsCommaStringEmpty self assert: self empty asCommaString = ''. self assert: self empty asCommaStringAnd = ''. ! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsCommaStringMore "self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'. self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3' " | result resultAnd index allElementsAsString | result:= self nonEmpty asCommaString . resultAnd:= self nonEmpty asCommaStringAnd . index := 1. (result findBetweenSubStrs: ',' )do: [:each | index = 1 ifTrue: [self assert: each= ((self nonEmpty at:index)asString)] ifFalse: [self assert: each= (' ',(self nonEmpty at:index) asString)]. index:=index+1 ]. "verifying esultAnd :" allElementsAsString:=(resultAnd findBetweenSubStrs: ',' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size ) ifTrue: [ i = 1 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i) asString)] ifFalse:[self assert: (allElementsAsString at:i)=(' ',(self nonEmpty at:i) asString)] ]. i=(allElementsAsString size) ifTrue:[ i = 1 ifTrue:[self assert: (allElementsAsString at:i)=( (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] ifFalse:[self assert: (allElementsAsString at:i)=( ' ' , (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] ]. ].! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsCommaStringOne "self assert: self oneItemCol asCommaString = '1'. self assert: self oneItemCol asCommaStringAnd = '1'." self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString). self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString). ! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsStringOnDelimiterEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim. self assert: emptyStream contents = ''. ! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsStringOnDelimiterLastEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim last:'and'. self assert: emptyStream contents = ''. ! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsStringOnDelimiterLastMore | delim multiItemStream result last allElementsAsString | delim := ', '. last := 'and'. result:=''. multiItemStream := ReadWriteStream on:result. self nonEmpty asStringOn: multiItemStream delimiter: ', ' last: last. allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. i=(allElementsAsString size-1) ifTrue:[ self deny: (allElementsAsString at:i)=(last)asString]. i=(allElementsAsString size) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. ]. ! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsStringOnDelimiterLastOne | delim oneItemStream result | delim := ', '. result:=''. oneItemStream := ReadWriteStream on: result. self nonEmpty1Element asStringOn: oneItemStream delimiter: delim last: 'and'. oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. ! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsStringOnDelimiterMore | delim multiItemStream result index | "delim := ', '. multiItemStream := '' readWrite. self oneTwoThreeItemCol asStringOn: multiItemStream delimiter: ', '. self assert: multiItemStream contents = '1, 2, 3'." delim := ', '. result:=''. multiItemStream := ReadWriteStream on:result. self nonEmpty asStringOn: multiItemStream delimiter: ', '. index:=1. (result findBetweenSubStrs: ', ' )do: [:each | self assert: each= ((self nonEmpty at:index)asString). index:=index+1 ].! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsStringOnDelimiterOne | delim oneItemStream result | "delim := ', '. oneItemStream := '' readWrite. self oneItemCol asStringOn: oneItemStream delimiter: delim. self assert: oneItemStream contents = '1'." delim := ', '. result:=''. oneItemStream := ReadWriteStream on: result. self nonEmpty1Element asStringOn: oneItemStream delimiter: delim. oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. ! ! !ArrayTest methodsFor: 'tests - concatenation'! testConcatenation | result index | result:= self firstCollection,self secondCollection . "first part : " index := 1. self firstCollection do: [:each | self assert: (self firstCollection at: index)=each. index := index+1.]. "second part : " 1 to: self secondCollection size do: [:i | self assert: (self secondCollection at:i)= (result at:index). index:=index+1]. "size : " self assert: result size = (self firstCollection size + self secondCollection size).! ! !ArrayTest methodsFor: 'tests - concatenation'! testConcatenationWithEmpty | result | result:= self empty,self secondCollection . 1 to: self secondCollection size do: [:i | self assert: (self secondCollection at:i)= (result at:i). ]. "size : " self assert: result size = ( self secondCollection size).! ! !ArrayTest methodsFor: 'tests - converting'! assertNoDuplicates: aCollection whenConvertedTo: aClass | result | result := self collectionWithEqualElements asIdentitySet. self assert: (result class includesBehavior: IdentitySet). self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) = 1 ]! ! !ArrayTest methodsFor: 'tests - converting'! assertNonDuplicatedContents: aCollection whenConvertedTo: aClass | result | result := aCollection perform: ('as' , aClass name) asSymbol. self assert: (result class includesBehavior: aClass). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. ^ result! ! !ArrayTest methodsFor: 'tests - converting' stamp: 'cyrille.delaunay 3/26/2009 12:35'! assertSameContents: aCollection whenConvertedTo: aClass | result | result := aCollection perform: ('as' , aClass name) asSymbol. self assert: (result class includesBehavior: aClass). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = aCollection size! ! !ArrayTest methodsFor: 'tests - converting' stamp: 'cyrille.delaunay 3/26/2009 14:55'! testAsArray "self debug: #testAsArray3" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Array! ! !ArrayTest methodsFor: 'tests - converting'! testAsBag self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! !ArrayTest methodsFor: 'tests - converting'! testAsByteArray | res | self shouldnt: [self integerCollectionWithoutEqualElements ] raise: Error. self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger] . res := true. self integerCollectionWithoutEqualElements detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! ! !ArrayTest methodsFor: 'tests - converting'! testAsIdentitySet "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: IdentitySet. ! ! !ArrayTest methodsFor: 'tests - converting'! testAsOrderedCollection self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! !ArrayTest methodsFor: 'tests - converting'! testAsSet | | "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set. ! ! !ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! testCopyEmptyWith "self debug: #testCopyWith" | res | res := self empty copyWith: self elementToAdd. self assert: res size = (self empty size + 1). self assert: (res includes: self elementToAdd)! ! !ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! testCopyEmptyWithout "self debug: #testCopyEmptyWithout" | res | res := self empty copyWithout: self elementToAdd. self assert: res size = self empty size. self deny: (res includes: self elementToAdd)! ! !ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:24'! testCopyEmptyWithoutAll "self debug: #testCopyEmptyWithoutAll" | res | res := self empty copyWithoutAll: self collectionWithElementsToRemove. self assert: res size = self empty size. self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! ! !ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! testCopyNonEmptyWith "self debug: #testCopyNonEmptyWith" | res | res := self nonEmpty copyWith: self elementToAdd. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self assert: (res includes: self elementToAdd). self nonEmpty do: [ :each | res includes: each ]! ! !ArrayTest methodsFor: 'tests - copy'! testCopyNonEmptyWithout "self debug: #testCopyNonEmptyWithout" | res anElementOfTheCollection | anElementOfTheCollection := self nonEmpty anyOne. res := (self nonEmpty copyWithout: anElementOfTheCollection). "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self deny: (res includes: anElementOfTheCollection). self nonEmpty do: [:each | (each = anElementOfTheCollection) ifFalse: [self assert: (res includes: each)]]. ! ! !ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:24'! testCopyNonEmptyWithoutAll "self debug: #testCopyNonEmptyWithoutAll" | res | res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]. self nonEmpty do: [ :each | (self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! ! !ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 3/30/2009 10:33'! testCopyNonEmptyWithoutAllNotIncluded ! ! !ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! testCopyNonEmptyWithoutNotIncluded "self debug: #testCopyNonEmptyWithoutNotIncluded" | res | res := self nonEmpty copyWithout: self elementToAdd. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! !ArrayTest methodsFor: 'tests - copy - clone'! testCopyCreatesNewObject "self debug: #testCopyCreatesNewObject" | copy | copy := self nonEmpty copy. self deny: self nonEmpty == copy. ! ! !ArrayTest methodsFor: 'tests - copy - clone'! testCopyEmpty "self debug: #testCopyEmpty" | copy | copy := self empty copy. self assert: copy isEmpty.! ! !ArrayTest methodsFor: 'tests - copy - clone'! testCopyNonEmpty "self debug: #testCopyNonEmpty" | copy | copy := self nonEmpty copy. self deny: copy isEmpty. self assert: copy size = self nonEmpty size. self nonEmpty do: [:each | copy includes: each]! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyAfter | result index collection | collection := self collectionWithoutEqualsElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyAfter: (collection at:index ). "verifying content: " (1) to: result size do: [:i | self assert: (collection at:(i + index ))=(result at: (i))]. "verify size: " self assert: result size = (collection size - index).! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyAfterEmpty | result | result := self empty copyAfter: self collectionWithoutEqualsElements first. self assert: result isEmpty. ! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyAfterLast | result index collection | collection := self collectionWithoutEqualsElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyAfterLast: (collection at:index ). "verifying content: " (1) to: result size do: [:i | self assert: (collection at:(i + index ))=(result at: (i))]. "verify size: " self assert: result size = (collection size - index).! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyAfterLastEmpty | result | result := self empty copyAfterLast: self collectionWithoutEqualsElements first. self assert: result isEmpty.! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyEmptyMethod | result | result := self collectionWithoutEqualsElements copyEmpty . self assert: result isEmpty . self assert: result class= self nonEmpty class.! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyFromTo | result index collection | collection := self collectionWithoutEqualsElements . index :=self indexInForCollectionWithoutDuplicates . result := collection copyFrom: index to: collection size . "verify content of 'result' : " 1 to: result size do: [:i | self assert: (result at:i)=(collection at: (i + index - 1))]. "verify size of 'result' : " self assert: result size = (collection size - index + 1).! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyUpTo | result index collection | collection := self collectionWithoutEqualsElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyUpTo: (collection at:index). "verify content of 'result' :" 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. "verify size of 'result' :" self assert: result size = (index-1). ! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyUpToEmpty | result | result := self empty copyUpTo: self collectionWithoutEqualsElements first. self assert: result isEmpty. ! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyUpToLast | result index collection | collection := self collectionWithoutEqualsElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyUpToLast: (collection at:index). "verify content of 'result' :" 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. "verify size of 'result' :" self assert: result size = (index-1).! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyUpToLastEmpty | result | result := self empty copyUpToLast: self collectionWithoutEqualsElements first. self assert: result isEmpty.! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness'! testCopyAfterLastWithDuplicate | result element collection | collection := self collectionWithSameAtEndAndBegining . element := collection first. " collectionWithSameAtEndAndBegining first and last elements are equals. 'copyAfter:' should copy after the last occurence of element :" result := collection copyAfterLast: (element ). "verifying content: " self assert: result isEmpty. ! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness'! testCopyAfterWithDuplicate | result element collection | collection := self collectionWithSameAtEndAndBegining . element := collection last. " collectionWithSameAtEndAndBegining first and last elements are equals. 'copyAfter:' should copy after the first occurence :" result := collection copyAfter: (element ). "verifying content: " 1 to: result size do: [:i | self assert: (collection at:(i + 1 )) = (result at: (i)) ]. "verify size: " self assert: result size = (collection size - 1).! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness'! testCopyUpToLastWithDuplicate | result element collection | collection := self collectionWithSameAtEndAndBegining . element := collection first. " collectionWithSameAtEndAndBegining first and last elements are equals. 'copyUpToLast:' should copy until the last occurence :" result := collection copyUpToLast: (element ). "verifying content: " 1 to: result size do: [:i | self assert: (result at: i ) = ( collection at: i ) ]. self assert: result size = (collection size - 1). ! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness'! testCopyUpToWithDuplicate | result element collection | collection := self collectionWithSameAtEndAndBegining . element := collection last. " collectionWithSameAtEndAndBegining first and last elements are equals. 'copyUpTo:' should copy until the first occurence :" result := collection copyUpTo: (element ). "verifying content: " self assert: result isEmpty. ! ! !ArrayTest methodsFor: 'tests - copying same contents'! testReverse | result | result := self nonEmpty reverse . "verify content of 'result: '" 1 to: result size do: [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !ArrayTest methodsFor: 'tests - copying same contents'! testReversed | result | result := self nonEmpty reversed . "verify content of 'result: '" 1 to: result size do: [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !ArrayTest methodsFor: 'tests - copying same contents'! testShallowCopy | result | result := self nonEmpty shallowCopy . "verify content of 'result: '" 1 to: self nonEmpty size do: [:i | self assert: ((result at:i)=(self nonEmpty at:i))]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !ArrayTest methodsFor: 'tests - copying same contents'! testShallowCopyEmpty | result | result := self empty shallowCopy . self assert: result isEmpty .! ! !ArrayTest methodsFor: 'tests - copying same contents'! testShuffled | result | result := self nonEmpty shuffled . "verify content of 'result: '" result do: [:each | self assert: (self nonEmpty occurrencesOf: each)=(result occurrencesOf: each)]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !ArrayTest methodsFor: 'tests - copying same contents'! testSortBy " can only be used if the collection tested can include sortable elements :" | result tmp | self shouldnt: [ self collectionWithSortableElements ] raise: Error. self shouldnt: [self collectionWithSortableElements anyOne < self collectionWithSortableElements anyOne] raise: Error. result := self collectionWithSortableElements sortBy: [ :a :b | a < b ]. "verify content of 'result' : " result do: [ :each | (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. tmp := result first. result do: [ :each | self assert: each >= tmp. tmp := each ]. "verify size of 'result' :" self assert: result size = self collectionWithSortableElements size! ! !ArrayTest methodsFor: 'tests - copying with or without'! testCopyWithFirst | index element result | index:= self indexInNonEmpty . element:= self nonEmpty at: index. result := self nonEmpty copyWithFirst: element. self assert: result size = (self nonEmpty size + 1). self assert: result first = element . 2 to: result size do: [ :i | self assert: (result at: i) = ( self nonEmpty at: ( i - 1 ))].! ! !ArrayTest methodsFor: 'tests - copying with or without'! testCopyWithSequenceable | result index element | index := self indexInNonEmpty . element := self nonEmpty at: index. result := self nonEmpty copyWith: (element ). self assert: result size = (self nonEmpty size + 1). self assert: result last = element . 1 to: (result size - 1) do: [ :i | self assert: (result at: i) = ( self nonEmpty at: ( i ))].! ! !ArrayTest methodsFor: 'tests - copying with or without'! testCopyWithoutFirst | result | result := self nonEmpty copyWithoutFirst. self assert: result size = (self nonEmpty size - 1). 1 to: result size do: [:i | self assert: (result at: i)= (self nonEmpty at: (i + 1))].! ! !ArrayTest methodsFor: 'tests - copying with or without'! testCopyWithoutIndex | result index | index := self indexInNonEmpty . result := self nonEmpty copyWithoutIndex: index . "verify content of 'result:'" 1 to: result size do: [:i | i<( index ) ifTrue: [self assert: ((result at:i )= (self nonEmpty at:i))]. i>=( index ) ifTrue: [self assert: (result at:i )= (self nonEmpty at:(i+1))]]. "verify size of result : " self assert: result size=(self nonEmpty size -1).! ! !ArrayTest methodsFor: 'tests - copying with or without'! testForceToPaddingStartWith | result element | element := self nonEmpty at: self indexInNonEmpty . result := self nonEmpty forceTo: (self nonEmpty size+2) paddingStartWith: ( element ). "verify content of 'result' : " 1 to: 2 do: [:i | self assert: ( element ) = ( result at:(i) ) ]. 3 to: result size do: [:i | self assert: ( result at:i ) = ( self nonEmpty at:(i-2) ) ]. "verify size of 'result' :" self assert: result size = (self nonEmpty size + 2).! ! !ArrayTest methodsFor: 'tests - copying with or without'! testForceToPaddingWith | result element | element := self nonEmpty at: self indexInNonEmpty . result := self nonEmpty forceTo: (self nonEmpty size+2) paddingWith: ( element ). "verify content of 'result' : " 1 to: self nonEmpty size do: [:i | self assert: ( self nonEmpty at: i ) = ( result at:(i) ). ]. (result size - 1) to: result size do: [:i | self assert: ( result at:i ) = ( element ) ]. "verify size of 'result' :" self assert: result size = (self nonEmpty size + 2).! ! !ArrayTest methodsFor: 'tests - copying with replacement'! firstIndexesOf: subCollection in: collection " return an OrderedCollection with the first indexes of the occurrences of subCollection in collection " | tmp result currentIndex | tmp:= collection. result:= OrderedCollection new. currentIndex := 1. [tmp isEmpty ]whileFalse: [ (tmp beginsWith: subCollection) ifTrue: [ result add: currentIndex. 1 to: subCollection size do: [:i | tmp := tmp copyWithoutFirst. currentIndex := currentIndex + 1] ] ifFalse: [ tmp := tmp copyWithoutFirst. currentIndex := currentIndex +1. ] ]. ^ result. ! ! !ArrayTest methodsFor: 'tests - copying with replacement'! testCopyReplaceAllWith1Occurence | result firstIndexesOfOccurrence index endPartIndexResult endPartIndexCollection | result := self collectionWith1TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection . "detecting indexes of olSubCollection" firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection . index:= firstIndexesOfOccurrence at: 1. "verify content of 'result' : " "first part of 'result'' : '" 1 to: (index -1) do: [ :i | self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) ]. " middle part containing replacementCollection : " index to: (index + self replacementCollection size-1) do: [ :i | self assert: ( result at: i )=(self replacementCollection at: ( i - index + 1 )) ]. " end part :" endPartIndexResult := index + self replacementCollection size . endPartIndexCollection := index + self oldSubCollection size . 1 to: (result size - endPartIndexResult - 1 ) do: [ :i | self assert: (result at: ( endPartIndexResult + i - 1 ) ) = (self collectionWith1TimeSubcollection at: ( endPartIndexCollection + i - 1 ) ). ]. ! ! !ArrayTest methodsFor: 'tests - copying with replacement'! testCopyReplaceAllWithManyOccurence | result firstIndexesOfOccurrence resultBetweenPartIndex collectionBetweenPartIndex diff | " testing fixture here as this method may be not used for collection that can't contain equals element :" self shouldnt: [self collectionWith2TimeSubcollection ]raise: Error. self assert: (self howMany: self oldSubCollection in: self collectionWith2TimeSubcollection ) = 2. " test :" diff := self replacementCollection size - self oldSubCollection size. result := self collectionWith2TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection . "detecting indexes of olSubCollection" firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith2TimeSubcollection . " verifying that replacementCollection has been put in places of oldSubCollections " firstIndexesOfOccurrence do: [ :each | (firstIndexesOfOccurrence indexOf: each) = 1 ifTrue: [ each to: self replacementCollection size do: [ :i | self assert: (result at: i) = ( self replacementCollection at: ( i - each + 1 ) ) ]. ] ifFalse:[ (each + diff) to: self replacementCollection size do: [ :i | self assert: (result at: i) = ( self replacementCollection at: ( i - each + 1 ) ) ]. ]. ]. " verifying that the 'between' parts correspond to the initial collection : " 1 to: firstIndexesOfOccurrence size do: [ :i | i = 1 " specific comportement for the begining of the collection :" ifTrue: [ 1 to: ((firstIndexesOfOccurrence at: i) - 1 ) do: [ :j | self assert: (result at: i) = (self collectionWith2TimeSubcollection at: i) ] ] " between parts till the end : " ifFalse: [ resultBetweenPartIndex := (firstIndexesOfOccurrence at: (i -1)) + self replacementCollection size. collectionBetweenPartIndex := (firstIndexesOfOccurrence at: (i -1)) + self oldSubCollection size. 1 to: ( firstIndexesOfOccurrence at: i) - collectionBetweenPartIndex - 1 do: [ :j | self assert: (result at: (resultBetweenPartIndex + i - 1)) = (self collectionWith2TimeSubcollection at: (collectionBetweenPartIndex +i - 1)) ] ] ]. "final part :" 1 to: (self collectionWith2TimeSubcollection size - (firstIndexesOfOccurrence last + self oldSubCollection size ) ) do: [ :i | self assert: ( result at:(firstIndexesOfOccurrence last + self replacementCollection size -1) + i ) = ( self collectionWith2TimeSubcollection at:(firstIndexesOfOccurrence last + self oldSubCollection size -1) + i ) . ]! ! !ArrayTest methodsFor: 'tests - copying with replacement'! testCopyReplaceFromToWith | result indexOfSubcollection lastIndexOfOldSubcollection lastIndexOfReplacementCollection | indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. lastIndexOfOldSubcollection := indexOfSubcollection + self oldSubCollection size -1. lastIndexOfReplacementCollection := indexOfSubcollection + self replacementCollection size -1. result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: lastIndexOfOldSubcollection with: self replacementCollection . "verify content of 'result' : " "first part of 'result' " 1 to: (indexOfSubcollection - 1) do: [ :i | self assert: (self collectionWith1TimeSubcollection at:i) = (result at: i) ]. " middle part containing replacementCollection : " (indexOfSubcollection ) to: ( lastIndexOfReplacementCollection ) do: [ :i | self assert: (result at: i)=(self replacementCollection at: (i - indexOfSubcollection +1)) ]. " end part :" 1 to: (result size - lastIndexOfReplacementCollection ) do: [ :i | self assert: (result at: ( lastIndexOfReplacementCollection + i ) ) = (self collectionWith1TimeSubcollection at: ( lastIndexOfOldSubcollection + i ) ). ]. ! ! !ArrayTest methodsFor: 'tests - copying with replacement'! testCopyReplaceFromToWithInsertion | result indexOfSubcollection | indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: ( indexOfSubcollection - 1 ) with: self replacementCollection . "verify content of 'result' : " "first part of 'result'' : '" 1 to: (indexOfSubcollection -1) do: [ :i | self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) ]. " middle part containing replacementCollection : " indexOfSubcollection to: (indexOfSubcollection + self replacementCollection size-1) do: [ :i | self assert: ( result at: i )=(self replacementCollection at: ( i - indexOfSubcollection +1 )) ]. " end part :" (indexOfSubcollection + self replacementCollection size) to: (result size) do: [:i| self assert: (result at: i)=(self collectionWith1TimeSubcollection at: (i-self replacementCollection size))]. " verify size: " self assert: result size=(self collectionWith1TimeSubcollection size + self replacementCollection size). ! ! !ArrayTest methodsFor: 'tests - element accessing'! testAfter "self debug: #testAfter" self assert: (self moreThan4Elements after: (self moreThan4Elements at: 1)) = (self moreThan4Elements at: 2). self should: [ self moreThan4Elements after: (self moreThan4Elements at: self moreThan4Elements size) ] raise: Error. self should: [ self moreThan4Elements after: self elementNotInForElementAccessing ] raise: Error! ! !ArrayTest methodsFor: 'tests - element accessing'! testAfterIfAbsent "self debug: #testAfterIfAbsent" self assert: (self moreThan4Elements after: (self moreThan4Elements at: 1) ifAbsent: [ 33 ]) = (self moreThan4Elements at: 2). self assert: (self moreThan4Elements after: (self moreThan4Elements at: self moreThan4Elements size) ifAbsent: [ 33 ]) == 33. self assert: (self moreThan4Elements after: self elementNotInForElementAccessing ifAbsent: [ 33 ]) = 33! ! !ArrayTest methodsFor: 'tests - element accessing'! testAt "self debug: #testAt" " self assert: (self accessCollection at: 1) = 1. self assert: (self accessCollection at: 2) = 2. " | index | index := self moreThan4Elements indexOf: self elementInForElementAccessing. self assert: (self moreThan4Elements at: index) = self elementInForElementAccessing! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtAll "self debug: #testAtAll" " self flag: #theCollectionshouldbe102030intheFixture. self assert: (self accessCollection atAll: #(2 1)) first = self accessCollection second. self assert: (self accessCollection atAll: #(2)) first = self accessCollection second." | result | result := self moreThan4Elements atAll: #(2 1 2 ). self assert: (result at: 1) = (self moreThan4Elements at: 2). self assert: (result at: 2) = (self moreThan4Elements at: 1). self assert: (result at: 3) = (self moreThan4Elements at: 2). self assert: (self moreThan4Elements atAll: #()) = self moreThan4Elements species new! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtIfAbsent "self debug: #testAt" | absent | absent := false. self moreThan4Elements at: self moreThan4Elements size + 1 ifAbsent: [ absent := true ]. self assert: absent = true. absent := false. self moreThan4Elements at: self moreThan4Elements size ifAbsent: [ absent := true ]. self assert: absent = false! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtLast "self debug: #testAtLast" | index | self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last. "tmp:=1. self do: [:each | each =self elementInForIndexAccessing ifTrue:[index:=tmp]. tmp:=tmp+1]." index := self moreThan4Elements indexOf: self elementInForElementAccessing. self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtLastError "self debug: #testAtLast" self should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ] raise: Error! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtLastIfAbsent "self debug: #testAtLastIfAbsent" self assert: (self moreThan4Elements atLast: 1 ifAbsent: [ nil ]) = self moreThan4Elements last. self assert: (self moreThan4Elements atLast: self moreThan4Elements size + 1 ifAbsent: [ 222 ]) = 222! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtOutOfBounds "self debug: #testAtOutOfBounds" self should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ] raise: Error. self should: [ self moreThan4Elements at: -1 ] raise: Error! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtPin "self debug: #testAtPin" self assert: (self moreThan4Elements atPin: 2) = self moreThan4Elements second. self assert: (self moreThan4Elements atPin: 99) = self moreThan4Elements last. self assert: (self moreThan4Elements atPin: -99) = self moreThan4Elements first! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtRandom | result | result := self nonEmpty atRandom . self assert: (self nonEmpty includes: result).! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtWrap "self debug: #testAt" " self assert: (self accessCollection at: 1) = 1. self assert: (self accessCollection at: 2) = 2. " | index | index := self moreThan4Elements indexOf: self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: index) = self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: index + self moreThan4Elements size) = self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: index - self moreThan4Elements size) = self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: 1 + self moreThan4Elements size) = (self moreThan4Elements at: 1)! ! !ArrayTest methodsFor: 'tests - element accessing'! testBefore "self debug: #testBefore" self assert: (self moreThan4Elements before: (self moreThan4Elements at: 2)) = (self moreThan4Elements at: 1). self should: [ self moreThan4Elements before: (self moreThan4Elements at: 1) ] raise: Error. self should: [ self moreThan4Elements before: 66 ] raise: Error! ! !ArrayTest methodsFor: 'tests - element accessing'! testBeforeIfAbsent "self debug: #testBefore" self assert: (self moreThan4Elements before: (self moreThan4Elements at: 1) ifAbsent: [ 99 ]) = 99. self assert: (self moreThan4Elements before: (self moreThan4Elements at: 2) ifAbsent: [ 99 ]) = (self moreThan4Elements at: 1)! ! !ArrayTest methodsFor: 'tests - element accessing'! testFirstSecondThird "self debug: #testFirstSecondThird" self assert: self moreThan4Elements first = (self moreThan4Elements at: 1). self assert: self moreThan4Elements second = (self moreThan4Elements at: 2). self assert: self moreThan4Elements third = (self moreThan4Elements at: 3). self assert: self moreThan4Elements fourth = (self moreThan4Elements at: 4)! ! !ArrayTest methodsFor: 'tests - element accessing'! testLast "self debug: #testLast" self assert: self moreThan4Elements last = (self moreThan4Elements at: self moreThan4Elements size)! ! !ArrayTest methodsFor: 'tests - element accessing'! testMiddle "self debug: #testMiddle" self assert: self moreThan4Elements middle = (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! ! !ArrayTest methodsFor: 'tests - equality'! testEqualSignForSequenceableCollections "self debug: #testEqualSign" self deny: (self nonEmpty = self nonEmpty asSet). self deny: (self nonEmpty reversed = self nonEmpty). self deny: (self nonEmpty = self nonEmpty reversed).! ! !ArrayTest methodsFor: 'tests - equality'! testHasEqualElements "self debug: #testHasEqualElements" self deny: (self empty hasEqualElements: self nonEmpty). self deny: (self nonEmpty hasEqualElements: self nonEmpty asSet). self deny: (self nonEmpty reversed hasEqualElements: self nonEmpty). self deny: (self nonEmpty hasEqualElements: self nonEmpty reversed).! ! !ArrayTest methodsFor: 'tests - equality'! testHasEqualElementsIsTrueForNonIdenticalButEqualCollections "self debug: #testHasEqualElementsIsTrueForNonIdenticalButEqualCollections" self assert: (self empty hasEqualElements: self empty copy). self assert: (self empty copy hasEqualElements: self empty). self assert: (self empty copy hasEqualElements: self empty copy). self assert: (self nonEmpty hasEqualElements: self nonEmpty copy). self assert: (self nonEmpty copy hasEqualElements: self nonEmpty). self assert: (self nonEmpty copy hasEqualElements: self nonEmpty copy).! ! !ArrayTest methodsFor: 'tests - equality'! testHasEqualElementsOfIdenticalCollectionObjects "self debug: #testHasEqualElementsOfIdenticalCollectionObjects" self assert: (self empty hasEqualElements: self empty). self assert: (self nonEmpty hasEqualElements: self nonEmpty). ! ! !ArrayTest methodsFor: 'tests - fixture'! howMany: subCollection in: collection " return an integer representing how many time 'subCollection' appears in 'collection' " | tmp nTime | tmp:= collection. nTime:= 0. [tmp isEmpty ]whileFalse: [ (tmp beginsWith: subCollection) ifTrue: [ nTime := nTime + 1. 1 to: subCollection size do: [:i | tmp := tmp copyWithoutFirst.] ] ifFalse: [tmp := tmp copyWithoutFirst.] ]. ^ nTime. ! ! !ArrayTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/17/2009 15:26'! test0CopyTest self shouldnt: self empty raise: Error. self assert: self empty size = 0. self shouldnt: self nonEmpty raise: Error. self assert: (self nonEmpty size = 0) not. self shouldnt: self collectionWithElementsToRemove raise: Error. self assert: (self collectionWithElementsToRemove size = 0) not. self shouldnt: self elementToAdd raise: Error! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureAsSetForIdentityMultiplinessTest "a collection (of elements for which copy is not identical ) without equal elements:" | element res | self shouldnt: [ self elementsCopyNonIdenticalWithoutEqualElements ]raise: Error. element := self elementsCopyNonIdenticalWithoutEqualElements anyOne. self deny: element copy == element . res := true. self elementsCopyNonIdenticalWithoutEqualElements detect: [ :each | (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false ! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureAsStringCommaAndDelimiterTest self shouldnt: [self nonEmpty] raise:Error . self deny: self nonEmpty isEmpty. self shouldnt: [self empty] raise:Error . self assert: self empty isEmpty. self shouldnt: [self nonEmpty1Element ] raise:Error . self assert: self nonEmpty1Element size=1.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureBeginsEndsWithTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self assert: self nonEmpty size>1. self shouldnt: [self empty ] raise: Error. self assert: self empty isEmpty.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCloneTest self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty. ! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureConverAsSortedTest self shouldnt: [self collectionWithSortableElements ] raise: Error. self deny: self collectionWithSortableElements isEmpty .! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCopyPartOfForMultipliness self shouldnt: [self collectionWithSameAtEndAndBegining ] raise: Error. self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. self assert: self collectionWithSameAtEndAndBegining size > 1. 1 to: self collectionWithSameAtEndAndBegining size do: [:i | (i > 1 ) & (i < self collectionWithSameAtEndAndBegining size) ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at:i) = (self collectionWithSameAtEndAndBegining first)]. ]! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCopyPartOfSequenceableTest self shouldnt: [self collectionWithoutEqualsElements ] raise: Error. self collectionWithoutEqualsElements do: [:each | self assert: (self collectionWithoutEqualsElements occurrencesOf: each)=1]. self shouldnt: [self indexInForCollectionWithoutDuplicates ] raise: Error. self assert: self indexInForCollectionWithoutDuplicates >0 & self indexInForCollectionWithoutDuplicates < self collectionWithoutEqualsElements size. self shouldnt: [self empty] raise: Error. self assert: self empty isEmpty .! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCopySameContentsTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [self empty ] raise: Error. self assert: self empty isEmpty. ! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCopyWithOrWithoutSpecificElementsTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty . self shouldnt: [self indexInNonEmpty ] raise: Error. self assert: self indexInNonEmpty > 0. self assert: self indexInNonEmpty <= self nonEmpty size.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCopyWithReplacementTest self shouldnt: [self replacementCollection ]raise: Error. self shouldnt: [self oldSubCollection] raise: Error. self shouldnt: [self collectionWith1TimeSubcollection ]raise: Error. self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection ) = 1. ! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCreationWithTest self shouldnt: [ self collectionMoreThan5Elements ] raise: Error. self assert: self collectionMoreThan5Elements size >= 5.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureEmptySequenceableTest self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty . self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty.! ! !ArrayTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/15/2009 14:37'! test0FixtureIncludeTest | elementIn | self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self elementNotIn ] raise: Error. elementIn := true. self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ elementIn := false ]. self assert: elementIn = false. self shouldnt: [ self anotherElementNotIn ] raise: Error. elementIn := true. self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ elementIn := false ]. self assert: elementIn = false. self shouldnt: [ self collection ] raise: Error. "self shouldnt: [self collectionInForIncluding ] raise: Error." "collectionIn:=false. index:=1. 1 to: self nonEmpty size do: [:i| collectionIn = false ifTrue:[(self nonEmpty at:i)=(self collectionInForIncluding at:index) ifTrue:[ index=self collectionInForIncluding ifTrue:[collectionIn := true]. index:=index+1.] ifFalse:[index:=1]. ] ]. self assert: collectionIn=true." self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty. self shouldnt: [ self collectionOfFloat ] raise: Error. self collectionOfFloat do: [ :each | self assert: each class = Float ]. self shouldnt: [ self elementInForIncludesTest ] raise: Error. elementIn := true. self nonEmpty detect: [ :each | each = self elementInForIncludesTest ] ifNone: [ elementIn := false ]. self assert: elementIn = true! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureIncludeWithIdentityTest | element | self shouldnt: [ self collectionWithCopyNonIdentical ]raise: Error. element := self collectionWithCopyNonIdentical anyOne. self deny: element == element copy. ! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureIndexAccessFotMultipliness self shouldnt: [ self collectionWithSameAtEndAndBegining ] raise: Error. self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. self assert: self collectionWithSameAtEndAndBegining size > 1. 1 to: self collectionWithSameAtEndAndBegining size do: [ :i | i > 1 & (i < self collectionWithSameAtEndAndBegining size) ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureIndexAccessTest | res collection element | self shouldnt: [ self collectionMoreThan1NoDuplicates ] raise: Error. self assert: self collectionMoreThan1NoDuplicates size >1. res := true. self collectionMoreThan1NoDuplicates detect: [ :each | (self collectionMoreThan1NoDuplicates occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. self shouldnt: [ self elementInForIndexAccessing ] raise: Error. self assert: ( (collection := self collectionMoreThan1NoDuplicates )includes: (element:= self elementInForIndexAccessing)). self shouldnt: [ self elementNotInForIndexAccessing ] raise: Error. self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureIterateSequencedReadableTest | res | self shouldnt: self nonEmptyMoreThan1Element raise: Error. self assert: self nonEmptyMoreThan1Element size > 1. self shouldnt: self empty raise: Error. self assert: self empty isEmpty . res := true. self nonEmptyMoreThan1Element detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureOccurrencesForMultiplinessTest | cpt element collection | self shouldnt: [self collectionWithEqualElements ]raise: Error. self shouldnt: [self collectionWithEqualElements ]raise: Error. self shouldnt: [ self elementTwiceInForOccurrences ] raise: Error. element := self elementTwiceInForOccurrences . collection := self collectionWithEqualElements . cpt := 0 . " testing with identity check ( == ) so that identy collections can use this trait : " self collectionWithEqualElements do: [ :each | each == self elementTwiceInForOccurrences ifTrue: [ cpt := cpt + 1 ] ]. self assert: cpt = 2.! ! !ArrayTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/2/2009 11:53'! test0FixtureOccurrencesTest self shouldnt: self empty raise: Error. self assert: self empty isEmpty. self shouldnt: self nonEmpty raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: self elementInForOccurrences raise: Error. self assert: (self nonEmpty includes: self elementInForOccurrences). self shouldnt: self elementNotInForOccurrences raise: Error. self deny: (self nonEmpty includes: self elementNotInForOccurrences)! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixturePrintTest self shouldnt: [self nonEmpty ] raise: Error.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixturePutOneOrMoreElementsTest self shouldnt: self aValue raise: Error. self shouldnt: self indexArray raise: Error. self indexArray do: [ :each| self assert: each class = SmallInteger. self assert: (each>=1 & each<= self nonEmpty size). ]. self assert: self indexArray size = self valueArray size. self shouldnt: self empty raise: Error. self assert: self empty isEmpty . self shouldnt: self nonEmpty raise: Error. self deny: self nonEmpty isEmpty.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixturePutTest self shouldnt: self aValue raise: Error. self shouldnt: self anotherValue raise: Error. self shouldnt: self anIndex raise: Error. self nonEmpty isDictionary ifFalse:[self assert: (self anIndex >=1 & self anIndex <= self nonEmpty size).]. self shouldnt: self empty raise: Error. self assert: self empty isEmpty . self shouldnt: self nonEmpty raise: Error. self deny: self nonEmpty isEmpty.! ! !ArrayTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/14/2009 11:50'! test0FixtureSequencedConcatenationTest self shouldnt: self empty raise: Exception. self assert: self empty isEmpty. self shouldnt: self firstCollection raise: Exception. self shouldnt: self secondCollection raise: Exception! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureSequencedElementAccessTest self shouldnt: [ self moreThan4Elements ] raise: Error. self assert: self moreThan4Elements size >= 4. self shouldnt: [ self subCollectionNotIn ] raise: Error. self subCollectionNotIn detect: [ :each | (self moreThan4Elements includes: each) not ] ifNone: [ self assert: false ]. self shouldnt: [ self elementNotInForElementAccessing ] raise: Error. self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing). self shouldnt: [ self elementInForElementAccessing ] raise: Error. self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureSetAritmeticTest self shouldnt: [ self collection ] raise: Error. self deny: self collection isEmpty. self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self anotherElementOrAssociationNotIn ] raise: Error. self collection isDictionary ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. self shouldnt: [ self collectionClass ] raise: Error! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureSubcollectionAccessTest self shouldnt: [ self moreThan3Elements ] raise: Error. self assert: self moreThan3Elements size > 2! ! !ArrayTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/28/2009 14:11'! test0FixtureTConvertAsSetForMultiplinessTest "a collection ofFloat with equal elements:" | res | self shouldnt: [ self withEqualElements ] raise: Error. self shouldnt: [ self withEqualElements do: [ :each | self assert: each class = Float ] ] raise: Error. res := true. self withEqualElements detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = true. "a collection of Float without equal elements:" self shouldnt: [ self elementsCopyNonIdenticalWithoutEqualElements ] raise: Error. self shouldnt: [ self elementsCopyNonIdenticalWithoutEqualElements do: [ :each | self assert: each class = Float ] ] raise: Error. res := true. self elementsCopyNonIdenticalWithoutEqualElements detect: [ :each | (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureTConvertTest "a collection of number without equal elements:" | res | self shouldnt: [ self collectionWithoutEqualElements ]raise: Error. res := true. self collectionWithoutEqualElements detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. ! ! !ArrayTest methodsFor: 'tests - fixture'! test0SortingArrayedTest | tmp sorted | " an unsorted collection of number " self shouldnt: [ self unsortedCollection ]raise: Error. self unsortedCollection do:[:each | each isNumber]. sorted := true. self unsortedCollection pairsDo: [ :each1 :each2 | each2 < each1 ifTrue: [ sorted := false]. ]. self assert: sorted = false. " a collection of number sorted in an ascending order" self shouldnt: [ self sortedInAscendingOrderCollection ]raise: Error. self sortedInAscendingOrderCollection do:[:each | each isNumber]. tmp:= self sortedInAscendingOrderCollection at:1. self sortedInAscendingOrderCollection do: [: each | self assert: (each>= tmp). tmp:=each] ! ! !ArrayTest methodsFor: 'tests - fixture'! test0TSequencedStructuralEqualityTest self shouldnt: [self nonEmpty at: 1] raise: Error. "Ensures #nonEmpty is sequenceable"! ! !ArrayTest methodsFor: 'tests - fixture'! test0TStructuralEqualityTest self shouldnt: [self empty] raise: Error. self shouldnt: [self nonEmpty] raise: Error. self assert: self empty isEmpty. self deny: self nonEmpty isEmpty.! ! !ArrayTest methodsFor: 'tests - fixture'! testOFixtureReplacementSequencedTest self shouldnt: self nonEmpty raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: self elementInForReplacement raise: Error. self assert: (self nonEmpty includes: self elementInForReplacement ) . self shouldnt: self newElement raise: Error. self shouldnt: self firstIndex raise: Error. self assert: (self firstIndex >= 1 & self firstIndex <= self nonEmpty size). self shouldnt: self secondIndex raise: Error. self assert: (self secondIndex >= 1 & self secondIndex <= self nonEmpty size). self assert: self firstIndex <=self secondIndex . self shouldnt: self replacementCollection raise: Error. self shouldnt: self replacementCollectionSameSize raise: Error. self assert: (self secondIndex - self firstIndex +1)= self replacementCollectionSameSize size ! ! !ArrayTest methodsFor: 'tests - includes' stamp: 'delaunay 4/28/2009 10:22'! testIdentityIncludes " test the comportement in presence of elements 'includes' but not 'identityIncludes' " " can not be used by collections that can't include elements for wich copy doesn't return another instance " | collection element | self shouldnt: [ self collectionWithCopyNonIdentical ] raise: Error. collection := self collectionWithCopyNonIdentical. element := collection anyOne copy. "self assert: (collection includes: element)." self deny: (collection identityIncludes: element)! ! !ArrayTest methodsFor: 'tests - includes'! testIdentityIncludesNonSpecificComportement " test the same comportement than 'includes: ' " | collection | collection := self nonEmpty . self deny: (collection identityIncludes: self elementNotIn ). self assert:(collection identityIncludes: collection anyOne) ! ! !ArrayTest methodsFor: 'tests - includes'! testIncludesAllOfAllThere "self debug: #testIncludesAllOfAllThere'" self assert: (self empty includesAllOf: self empty). self assert: (self nonEmpty includesAllOf: { self nonEmpty anyOne }). self assert: (self nonEmpty includesAllOf: self nonEmpty).! ! !ArrayTest methodsFor: 'tests - includes'! testIncludesAllOfNoneThere "self debug: #testIncludesAllOfNoneThere'" self deny: (self empty includesAllOf: self nonEmpty ). self deny: (self nonEmpty includesAllOf: { self elementNotIn. self anotherElementNotIn })! ! !ArrayTest methodsFor: 'tests - includes'! testIncludesAnyOfAllThere "self debug: #testIncludesAnyOfAllThere'" self deny: (self nonEmpty includesAnyOf: self empty). self assert: (self nonEmpty includesAnyOf: { self nonEmpty anyOne }). self assert: (self nonEmpty includesAnyOf: self nonEmpty).! ! !ArrayTest methodsFor: 'tests - includes'! testIncludesAnyOfNoneThere "self debug: #testIncludesAnyOfNoneThere'" self deny: (self nonEmpty includesAnyOf: self empty). self deny: (self nonEmpty includesAnyOf: { self elementNotIn. self anotherElementNotIn })! ! !ArrayTest methodsFor: 'tests - includes'! testIncludesElementIsNotThere "self debug: #testIncludesElementIsNotThere" self deny: (self nonEmpty includes: self elementNotIn). self assert: (self nonEmpty includes: self nonEmpty anyOne). self deny: (self empty includes: self elementNotIn)! ! !ArrayTest methodsFor: 'tests - includes'! testIncludesElementIsThere "self debug: #testIncludesElementIsThere" self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/15/2009 14:22'! testIdentityIndexOf "self debug: #testIdentityIndexOf" | collection element | element := self elementInCollectionOfFloat copy. self deny: self elementInCollectionOfFloat == element. collection := self collectionOfFloat copyWith: element. self assert: (collection identityIndexOf: element) = collection size! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/15/2009 14:22'! testIdentityIndexOfIAbsent "self debug: #testIdentityIndexOfIfAbsent" | collection element | element := self elementInCollectionOfFloat copy. self deny: self elementInCollectionOfFloat == element. collection := self collectionOfFloat copyWith: element. self assert: (collection identityIndexOf: element ifAbsent: [ 0 ]) = collection size. self assert: (self collectionOfFloat identityIndexOf: element ifAbsent: [ 55 ]) = 55! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testIndexOf "self debug: #testIndexOf" | tmp index collection | collection := self collectionMoreThan1NoDuplicates. tmp := collection size. collection reverseDo: [ :each | each = self elementInForIndexAccessing ifTrue: [ index := tmp ]. tmp := tmp - 1 ]. self assert: (collection indexOf: self elementInForIndexAccessing) = index! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testIndexOfIfAbsent "self debug: #testIndexOfIfAbsent" | collection | collection := self collectionMoreThan1NoDuplicates. self assert: (collection indexOf: collection first ifAbsent: [ 33 ]) = 1. self assert: (collection indexOf: self elementNotInForIndexAccessing ifAbsent: [ 33 ]) = 33! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testIndexOfStartingAt "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection indexOf: element startingAt: 2 ifAbsent: [ 99 ]) = 99. self assert: (collection indexOf: element startingAt: 1 ifAbsent: [ 99 ]) = 1. self assert: (collection indexOf: self elementNotInForIndexAccessing startingAt: 1 ifAbsent: [ 99 ]) = 99! ! !ArrayTest methodsFor: 'tests - index access'! testIndexOfStartingAtIfAbsent "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection indexOf: element startingAt: 2 ifAbsent: [ 99 ]) = 99. self assert: (collection indexOf: element startingAt: 1 ifAbsent: [ 99 ]) = 1. self assert: (collection indexOf: self elementNotInForIndexAccessing startingAt: 1 ifAbsent: [ 99 ]) = 99! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testIndexOfSubCollectionStartingAt "self debug: #testIndexOfIfAbsent" | subcollection index collection | collection := self collectionMoreThan1NoDuplicates. subcollection := self collectionMoreThan1NoDuplicates. index := collection indexOfSubCollection: subcollection startingAt: 1. self assert: index = 1. index := collection indexOfSubCollection: subcollection startingAt: 2. self assert: index = 0! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testIndexOfSubCollectionStartingAtIfAbsent "self debug: #testIndexOfIfAbsent" | index absent subcollection collection | collection := self collectionMoreThan1NoDuplicates. subcollection := self collectionMoreThan1NoDuplicates. absent := false. index := collection indexOfSubCollection: subcollection startingAt: 1 ifAbsent: [ absent := true ]. self assert: absent = false. absent := false. index := collection indexOfSubCollection: subcollection startingAt: 2 ifAbsent: [ absent := true ]. self assert: absent = true! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testLastIndexOf "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection lastIndexOf: element) = 1. self assert: (collection lastIndexOf: self elementNotInForIndexAccessing) = 0! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testLastIndexOfIfAbsent "self debug: #testIndexOfIfAbsent" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection lastIndexOf: element ifAbsent: [ 99 ]) = 1. self assert: (collection lastIndexOf: self elementNotInForIndexAccessing ifAbsent: [ 99 ]) = 99! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testLastIndexOfStartingAt "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection last. self assert: (collection lastIndexOf: element startingAt: collection size ifAbsent: [ 99 ]) = collection size. self assert: (collection lastIndexOf: element startingAt: collection size - 1 ifAbsent: [ 99 ]) = 99. self assert: (collection lastIndexOf: self elementNotInForIndexAccessing startingAt: collection size ifAbsent: [ 99 ]) = 99! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness'! testIdentityIndexOfDuplicate "self debug: #testIdentityIndexOf" | collection element | "testing fixture here as this method may not be used by some collections testClass" self shouldnt: [self collectionWithNonIdentitySameAtEndAndBegining ] raise: Error. collection := self collectionWithNonIdentitySameAtEndAndBegining . self assert: collection first = collection last. self deny: collection first == collection last. 1 to: collection size do: [ :i | i > 1 & (i < collection size) ifTrue: [ self deny: (collection at: i) = collection first ] ]. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals but are not the same object" self assert: (collection identityIndexOf: element) = collection size! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness'! testIdentityIndexOfIAbsentDuplicate "self debug: #testIdentityIndexOfIfAbsent" | collection element elementCopy | collection := self collectionWithNonIdentitySameAtEndAndBegining . element := collection last. elementCopy := element copy. self deny: element == elementCopy . self assert: (collection identityIndexOf: element ifAbsent: [ 0 ]) = collection size. self assert: (collection identityIndexOf: elementCopy ifAbsent: [ 55 ]) = 55! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness'! testIndexOfDuplicate "self debug: #testIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'indexOf: should return the position of the first occurrence :'" self assert: (collection indexOf: element) = 1! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness'! testIndexOfIfAbsentDuplicate "self debug: #testIndexOfIfAbsent" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'indexOf:ifAbsent: should return the position of the first occurrence :'" self assert: (collection indexOf: element ifAbsent: [ 55 ]) = 1! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness'! testIndexOfStartingAtDuplicate "self debug: #testLastIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'indexOf:ifAbsent:startingAt: should return the position of the first occurrence :'" self assert: (collection indexOf: element startingAt: 1 ifAbsent: [ 55 ]) = 1. self assert: (collection indexOf: element startingAt: 2 ifAbsent: [ 55 ]) = collection size! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness'! testLastIndexOfDuplicate "self debug: #testLastIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection first. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'lastIndexOf: should return the position of the last occurrence :'" self assert: (collection lastIndexOf: element) = collection size! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness'! testLastIndexOfIfAbsentDuplicate "self debug: #testIndexOfIfAbsent" "self debug: #testLastIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection first. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'lastIndexOf: should return the position of the last occurrence :'" self assert: (collection lastIndexOf: element ifAbsent: [ 55 ]) = collection size! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness'! testLastIndexOfStartingAtDuplicate "self debug: #testLastIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'lastIndexOf:ifAbsent:startingAt: should return the position of the last occurrence :'" self assert: (collection lastIndexOf: element startingAt: collection size ifAbsent: [ 55 ]) = collection size. self assert: (collection lastIndexOf: element startingAt: collection size - 1 ifAbsent: [ 55 ]) = 1! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testAllButFirstDo | result | result:= OrderedCollection new. self nonEmptyMoreThan1Element allButFirstDo: [:each | result add: each]. 1 to: (result size) do: [:i| self assert: (self nonEmptyMoreThan1Element at:(i +1))=(result at:i)]. self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testAllButLastDo | result | result:= OrderedCollection new. self nonEmptyMoreThan1Element allButLastDo: [:each | result add: each]. 1 to: (result size) do: [:i| self assert: (self nonEmptyMoreThan1Element at:(i ))=(result at:i)]. self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testCollectFromTo | result | result:=self nonEmptyMoreThan1Element collect: [ :each | each ] from: 1 to: (self nonEmptyMoreThan1Element size - 1). 1 to: result size do: [ :i | self assert: (self nonEmptyMoreThan1Element at: i) = (result at: i) ]. self assert: result size = (self nonEmptyMoreThan1Element size - 1)! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testDetectSequenced " testing that detect keep the first element returning true for sequenceable collections " | element result | element := self nonEmptyMoreThan1Element at:1. result:=self nonEmptyMoreThan1Element detect: [:each | each notNil ]. self assert: result = element. ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testFindFirst | element result | element := self nonEmptyMoreThan1Element at:1. result:=self nonEmptyMoreThan1Element findFirst: [:each | each =element]. self assert: result=1. ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testFindFirstNotIn | result | result:=self empty findFirst: [:each | true]. self assert: result=0. ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testFindLast | element result | element := self nonEmptyMoreThan1Element at:self nonEmptyMoreThan1Element size. result:=self nonEmptyMoreThan1Element findLast: [:each | each =element]. self assert: result=self nonEmptyMoreThan1Element size. ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testFindLastNotIn | result | result:=self empty findFirst: [:each | true]. self assert: result=0. ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testFromToDo | result | result:= OrderedCollection new. self nonEmptyMoreThan1Element from: 1 to: (self nonEmptyMoreThan1Element size -1) do: [:each | result add: each]. 1 to: (self nonEmptyMoreThan1Element size -1) do: [:i| self assert: (self nonEmptyMoreThan1Element at:i )=(result at:i)]. self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testKeysAndValuesDo "| result | result:= OrderedCollection new. self nonEmptyMoreThan1Element keysAndValuesDo: [:i :value| result add: (value+i)]. 1 to: result size do: [:i| self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]" | indexes elements | indexes:= OrderedCollection new. elements := OrderedCollection new. self nonEmptyMoreThan1Element keysAndValuesDo: [:i :value| indexes add: (i). elements add: value]. (1 to: self nonEmptyMoreThan1Element size )do: [ :i | self assert: (indexes at: i) = i. self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). ]. self assert: indexes size = elements size. self assert: indexes size = self nonEmptyMoreThan1Element size . ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testKeysAndValuesDoEmpty | result | result:= OrderedCollection new. self empty keysAndValuesDo: [:i :value| result add: (value+i)]. self assert: result isEmpty .! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testPairsCollect | index result | index:=0. result:=self nonEmptyMoreThan1Element pairsCollect: [:each1 :each2 | self assert: ( self nonEmptyMoreThan1Element indexOf: each2 ) = (index := index + 2). (self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1). ]. result do: [:each | self assert: each = true]. ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testPairsDo | index | index:=1. self nonEmptyMoreThan1Element pairsDo: [:each1 :each2 | self assert:(self nonEmptyMoreThan1Element at:index)=each1. self assert:(self nonEmptyMoreThan1Element at:(index+1))=each2. index:=index+2]. self nonEmptyMoreThan1Element size odd ifTrue:[self assert: index=self nonEmptyMoreThan1Element size] ifFalse:[self assert: index=(self nonEmptyMoreThan1Element size+1)].! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testReverseDo | result | result:= OrderedCollection new. self nonEmpty reverseDo: [: each | result add: each]. 1 to: result size do: [:i| self assert: (result at: i)=(self nonEmpty at:(self nonEmpty size-i+1))].! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testReverseDoEmpty | result | result:= OrderedCollection new. self empty reverseDo: [: each | result add: each]. self assert: result isEmpty .! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testReverseWithDo | secondCollection result index | result:= OrderedCollection new. index := self nonEmptyMoreThan1Element size + 1. secondCollection:= self nonEmptyMoreThan1Element copy. self nonEmptyMoreThan1Element reverseWith: secondCollection do: [:a :b | self assert: (self nonEmptyMoreThan1Element indexOf: a ) = (index := index - 1 ). result add: (a = b)]. 1 to: result size do: [:i| self assert: (result at:i)=(true)]. self assert: result size = self nonEmptyMoreThan1Element size.! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testWithCollect | result newCollection index collection | index := 0. collection := self nonEmptyMoreThan1Element . newCollection := collection copy. result:=collection with: newCollection collect: [:a :b | self assert: (collection indexOf: a ) = ( index := index + 1). self assert: (a = b). b]. 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. self assert: result size = collection size.! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testWithCollectError self should: [self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error.! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testWithDo | secondCollection result index | result:= OrderedCollection new. secondCollection:= self nonEmptyMoreThan1Element copy. index := 0. self nonEmptyMoreThan1Element with: secondCollection do: [:a :b | self assert: (self nonEmptyMoreThan1Element indexOf: a) = ( index := index + 1). result add: (a =b)]. 1 to: result size do: [:i| self assert: (result at:i)=(true)]. self assert: result size = self nonEmptyMoreThan1Element size.! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testWithDoError self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error.! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testWithIndexCollect | result index collection | index := 0. collection := self nonEmptyMoreThan1Element . result := collection withIndexCollect: [:each :i | self assert: i = (index := index + 1). self assert: i = (collection indexOf: each) . each] . 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. self assert: result size = collection size.! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testWithIndexDo "| result | result:=Array new: self nonEmptyMoreThan1Element size. self nonEmptyMoreThan1Element withIndexDo: [:each :i | result at:i put:(each+i)]. 1 to: result size do:[: i | self assert: (result at:i)= ((self nonEmptyMoreThan1Element at: i) + i)]" | indexes elements | indexes:= OrderedCollection new. elements := OrderedCollection new. self nonEmptyMoreThan1Element withIndexDo: [:value :i | indexes add: (i). elements add: value]. (1 to: self nonEmptyMoreThan1Element size )do: [ :i | self assert: (indexes at: i) = i. self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). ]. self assert: indexes size = elements size. self assert: indexes size = self nonEmptyMoreThan1Element size . ! ! !ArrayTest methodsFor: 'tests - occurrencesOf' stamp: 'delaunay 4/2/2009 11:52'! testOccurrencesOf | result expected | result := self nonEmpty occurrencesOf: self elementInForOccurrences. expected := 0. self nonEmpty do: [ :each | self elementInForOccurrences = each ifTrue: [ expected := expected + 1 ] ]. self assert: result = expected! ! !ArrayTest methodsFor: 'tests - occurrencesOf' stamp: 'delaunay 4/2/2009 11:52'! testOccurrencesOfEmpty | result | result := self empty occurrencesOf: self elementInForOccurrences. self assert: result = 0! ! !ArrayTest methodsFor: 'tests - occurrencesOf' stamp: 'delaunay 4/2/2009 11:53'! testOccurrencesOfNotIn | result | result := self empty occurrencesOf: self elementNotInForOccurrences. self assert: result = 0! ! !ArrayTest methodsFor: 'tests - occurrencesOf for multipliness'! testOccurrencesOfForMultipliness | collection element | collection := self collectionWithEqualElements . element := self elementTwiceInForOccurrences . self assert: (collection occurrencesOf: element ) = 2. ! ! !ArrayTest methodsFor: 'tests - printing'! testPrintElementsOn | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printElementsOn: aStream . allElementsAsString:=(result findBetweenSubStrs: ' ' ). 1 to: allElementsAsString size do: [:i | self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). ].! ! !ArrayTest methodsFor: 'tests - printing'! testPrintNameOn | aStream result | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printNameOn: aStream . Transcript show: result asString. self nonEmpty class name first isVowel ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ] ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! ! !ArrayTest methodsFor: 'tests - printing'! testPrintOn | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printOn: aStream . allElementsAsString:=(result findBetweenSubStrs: ' ' ). 1 to: allElementsAsString size do: [:i | i=1 ifTrue:[ self accessCollection class name first isVowel ifTrue:[self assert: (allElementsAsString at:i)='an' ] ifFalse:[self assert: (allElementsAsString at:i)='a'].]. i=2 ifTrue:[self assert: (allElementsAsString at:i)=self accessCollection class name]. i>2 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString).]. ].! ! !ArrayTest methodsFor: 'tests - printing'! testPrintOnDelimiter | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printOn: aStream delimiter: ', ' . allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). ].! ! !ArrayTest methodsFor: 'tests - printing'! testPrintOnDelimiterLast | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printOn: aStream delimiter: ', ' last: 'and'. allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. i=(allElementsAsString size-1) ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString]. i=(allElementsAsString size) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. ].! ! !ArrayTest methodsFor: 'tests - printing'! testStoreOn " for the moment work only for collection that include simple elements such that Integer" "| string str result cuttedResult index elementsAsStringExpected elementsAsStringObtained tmp | string := ''. str := ReadWriteStream on: string. elementsAsStringExpected := OrderedCollection new. elementsAsStringObtained := OrderedCollection new. self nonEmpty do: [ :each | elementsAsStringExpected add: each asString]. self nonEmpty storeOn: str. result := str contents . cuttedResult := ( result findBetweenSubStrs: ';' ). index := 1. cuttedResult do: [ :each | index = 1 ifTrue: [ self assert: (each beginsWith: ( tmp := '((' , self nonEmpty class asString , ' new) add: ' )). tmp := each copyFrom: ( tmp size + 1) to: ( each size ). elementsAsStringObtained add: tmp. index := index + 1. ] ifFalse: [ index < cuttedResult size ifTrue:[self assert: (each beginsWith: ( tmp:= ' add: ' )). tmp := each copyFrom: ( tmp size + 1) to: ( each size ). elementsAsStringObtained add: tmp. index := index + 1.] ifFalse: [self assert: ( each = ' yourself)' ) ]. ] ]. elementsAsStringExpected do: [ :each | self assert: (elementsAsStringExpected occurrencesOf: each ) = ( elementsAsStringObtained occurrencesOf: each) ]" ! ! !ArrayTest methodsFor: 'tests - puting with indexes'! testAtAllIndexesPut self nonEmpty atAllPut: self aValue. self nonEmpty do:[ :each| self assert: each = self aValue]. ! ! !ArrayTest methodsFor: 'tests - puting with indexes'! testAtAllPut | | self nonEmpty atAll: self indexArray put: self aValue.. self indexArray do: [:i | self assert: (self nonEmpty at: i)=self aValue ]. ! ! !ArrayTest methodsFor: 'tests - puting with indexes'! testAtAllPutAll | valueArray | valueArray := self valueArray . self nonEmpty atAll: self indexArray putAll: valueArray . 1 to: self indexArray size do: [:i | self assert: (self nonEmpty at:(self indexArray at: i))= (valueArray at:i) ]! ! !ArrayTest methodsFor: 'tests - puting with indexes'! testAtLastPut | result index | index := self indexArray anyOne. result := self nonEmpty atLast: index put: self aValue. self assert: (self nonEmpty at: (self nonEmpty size +1 - index)) = self aValue .! ! !ArrayTest methodsFor: 'tests - puting with indexes'! testAtWrapPut "self debug: #testAtWrapPut" | index | index := self indexArray anyOne. self nonEmpty atWrap: 0 put: self aValue. self assert: (self nonEmpty at:(self nonEmpty size))=self aValue. self nonEmpty atWrap: (self nonEmpty size+1) put: self aValue. self assert: (self nonEmpty at:(1))=self aValue. self nonEmpty atWrap: (index ) put: self aValue. self assert: (self nonEmpty at: index ) = self aValue. self nonEmpty atWrap: (self nonEmpty size+index ) put: self aValue . self assert: (self nonEmpty at:(index ))=self aValue .! ! !ArrayTest methodsFor: 'tests - puting with indexes'! testFromToPut | collection index | index := self indexArray anyOne. collection := self nonEmpty copy. collection from: 1 to: index put: self aValue.. 1 to: index do: [:i | self assert: (collection at: i)= self aValue]. (index +1) to: collection size do: [:i | self assert: (collection at:i)= (self nonEmpty at:i)].! ! !ArrayTest methodsFor: 'tests - puting with indexes'! testSwapWith "self debug: #testSwapWith" | result index | index := self indexArray anyOne. result:= self nonEmpty copy . result swap: index with: 1. self assert: (result at: index) = (self nonEmpty at:1). self assert: (result at: 1) = (self nonEmpty at: index). ! ! !ArrayTest methodsFor: 'tests - replacing'! testReplaceAllWith | result collection oldElement newElement | collection := self nonEmpty . result := collection copy. oldElement := self elementInForReplacement . newElement := self newElement . result replaceAll: oldElement with: newElement . 1 to: collection size do: [: each | ( collection at: each ) = oldElement ifTrue: [ self assert: ( result at: each ) = newElement ]. ].! ! !ArrayTest methodsFor: 'tests - replacing'! testReplaceFromToWith | result collection replacementCollection firstIndex secondIndex | collection := self nonEmpty . replacementCollection := self replacementCollectionSameSize . firstIndex := self firstIndex . secondIndex := self secondIndex . result := collection copy. result replaceFrom: firstIndex to: secondIndex with: replacementCollection . "verify content of 'result' : " "first part of 'result'' : '" 1 to: ( firstIndex - 1 ) do: [ :i | self assert: (collection at:i ) = ( result at: i ) ]. " middle part containing replacementCollection : " ( firstIndex ) to: ( firstIndex + replacementCollection size - 1 ) do: [ :i | self assert: ( result at: i ) = ( replacementCollection at: ( i - firstIndex +1 ) ) ]. " end part :" ( firstIndex + replacementCollection size) to: (result size) do: [:i| self assert: ( result at: i ) = ( collection at: ( secondIndex + 1 - ( firstIndex + replacementCollection size ) + i ) ) ]. ! ! !ArrayTest methodsFor: 'tests - replacing'! testReplaceFromToWithStartingAt | result repStart collection replacementCollection firstIndex secondIndex | collection := self nonEmpty . result := collection copy. replacementCollection := self replacementCollectionSameSize . firstIndex := self firstIndex . secondIndex := self secondIndex . repStart := replacementCollection size - ( secondIndex - firstIndex + 1 ) + 1. result replaceFrom: firstIndex to: secondIndex with: replacementCollection startingAt: repStart . "verify content of 'result' : " "first part of 'result'' : '" 1 to: ( firstIndex - 1 ) do: [ :i | self assert: ( collection at:i ) = ( result at: i ) ]. " middle part containing replacementCollection : " ( firstIndex ) to: ( replacementCollection size - repStart +1 ) do: [:i| self assert: (result at: i)=( replacementCollection at: ( repStart + ( i -firstIndex ) ) ) ]. " end part :" ( firstIndex + replacementCollection size ) to: ( result size ) do: [ :i | self assert: ( result at: i ) = ( collection at: ( secondIndex + 1 - ( firstIndex + replacementCollection size ) + i ) ) ].! ! !ArrayTest methodsFor: 'tests - sequence isempty'! testSequenceAbleIfEmptyifNotEmptyDo "self debug: #testSequenceAbleIfEmptyifNotEmptyDo" self assert: (self nonEmpty ifEmpty: [false] ifNotEmptyDo: [:s | (self accessValuePutInOn: s) = self valuePutIn]).! ! !ArrayTest methodsFor: 'tests - sequence isempty'! testSequenceIfEmptyifNotEmptyDo "self debug #testSequenceIfEmptyifNotEmptyDo" self assert: (self nonEmpty ifEmpty: [false] ifNotEmptyDo: [:s | (self accessValuePutInOn: s) = self valuePutIn]).! ! !ArrayTest methodsFor: 'tests - sequence isempty'! testSequenceIfNotEmpty self assert: (self nonEmpty ifNotEmpty: [:s | self accessValuePutInOn: s]) = self valuePutIn! ! !ArrayTest methodsFor: 'tests - sequence isempty'! testSequenceIfNotEmptyDo self empty ifNotEmptyDo: [:s | self assert: false]. self assert: (self nonEmpty ifNotEmptyDo: [:s | self accessValuePutInOn: s]) = self valuePutIn ! ! !ArrayTest methodsFor: 'tests - sequence isempty'! testSequenceIfNotEmptyDoifNotEmpty self assert: (self nonEmpty ifNotEmptyDo: [:s | (self accessValuePutInOn: s) = self valuePutIn] ifEmpty: [false])! ! !ArrayTest methodsFor: 'tests - sequence isempty'! testSequenceIfNotEmptyifEmpty self assert: (self nonEmpty ifEmpty: [false] ifNotEmpty: [:s | (self accessValuePutInOn: s) = self valuePutIn])! ! !ArrayTest methodsFor: 'tests - set arithmetic'! containsAll: union of: one andOf: another self assert: (one allSatisfy: [:each | union includes: each]). self assert: (another allSatisfy: [:each | union includes: each])! ! !ArrayTest methodsFor: 'tests - set arithmetic'! numberOfSimilarElementsInIntersection ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testDifference "Answer the set theoretic difference of two collections." "self debug: #testDifference" self assert: (self collection difference: self collection) isEmpty. self assert: (self empty difference: self collection) isEmpty. self assert: (self collection difference: self empty) = self collection ! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testDifferenceWithNonNullIntersection "Answer the set theoretic difference of two collections." "self debug: #testDifferenceWithNonNullIntersection" " #(1 2 3) difference: #(2 4) -> #(1 3)" | res overlapping | overlapping := self collectionClass with: self anotherElementOrAssociationNotIn with: self anotherElementOrAssociationIn. res := self collection difference: overlapping. self deny: (res includes: self anotherElementOrAssociationIn). overlapping do: [ :each | self deny: (res includes: each) ]! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testDifferenceWithSeparateCollection "Answer the set theoretic difference of two collections." "self debug: #testDifferenceWithSeparateCollection" | res separateCol | separateCol := self collectionClass with: self anotherElementOrAssociationNotIn. res := self collection difference: separateCol. self deny: (res includes: self anotherElementOrAssociationNotIn). self assert: res = self collection. res := separateCol difference: self collection. self deny: (res includes: self collection anyOne). self assert: res = separateCol! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testIntersectionBasic "self debug: #testIntersectionBasic" | inter | inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). self deny: inter isEmpty. self assert: (inter includes: self anotherElementOrAssociationIn value)! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testIntersectionEmpty "self debug: #testIntersectionEmpty" | inter | inter := self empty intersection: self empty. self assert: inter isEmpty. inter := self empty intersection: self collection . self assert: inter = self empty. ! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testIntersectionItself "self debug: #testIntersectionItself" self assert: (self collection intersection: self collection) = self collection. ! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testIntersectionTwoSimilarElementsInIntersection "self debug: #testIntersectionBasic" | inter | inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) = self numberOfSimilarElementsInIntersection. self assert: (inter includes: self anotherElementOrAssociationIn value)! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testUnion "self debug: #testUnionOfEmpties" | union | union := self empty union: self nonEmpty. self containsAll: union of: self empty andOf: self nonEmpty. union := self nonEmpty union: self empty. self containsAll: union of: self empty andOf: self nonEmpty. union := self collection union: self nonEmpty. self containsAll: union of: self collection andOf: self nonEmpty.! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testUnionOfEmpties "self debug: #testUnionOfEmpties" self assert: (self empty union: self empty) isEmpty. ! ! !ArrayTest methodsFor: 'tests - sorting'! testIsSorted self assert: [ self sortedInAscendingOrderCollection isSorted ]. self deny: [ self unsortedCollection isSorted ]! ! !ArrayTest methodsFor: 'tests - sorting'! testIsSortedBy self assert: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | ab]). ! ! !ArrayTest methodsFor: 'tests - sorting'! testSort | result tmp | result := self unsortedCollection sort. tmp := result at: 1. result do: [:each | self assert: each>=tmp. tmp:= each. ].! ! !ArrayTest methodsFor: 'tests - sorting'! testSortUsingSortBlock | result tmp | result := self unsortedCollection sort: [:a :b | a>b]. tmp := result at: 1. result do: [:each | self assert: each<=tmp. tmp:= each. ].! ! !ArrayTest methodsFor: 'tests - subcollections access'! testAllButFirst "self debug: #testAllButFirst" | abf col | col := self moreThan3Elements. abf := col allButFirst. self deny: abf first = col first. self assert: abf size + 1 = col size! ! !ArrayTest methodsFor: 'tests - subcollections access'! testAllButFirstNElements "self debug: #testAllButFirst" | abf col | col := self moreThan3Elements. abf := col allButFirst: 2. 1 to: abf size do: [ :i | self assert: (abf at: i) = (col at: i + 2) ]. self assert: abf size + 2 = col size! ! !ArrayTest methodsFor: 'tests - subcollections access'! testAllButLast "self debug: #testAllButLast" | abf col | col := self moreThan3Elements. abf := col allButLast. self deny: abf last = col last. self assert: abf size + 1 = col size! ! !ArrayTest methodsFor: 'tests - subcollections access'! testAllButLastNElements "self debug: #testAllButFirst" | abf col | col := self moreThan3Elements. abf := col allButLast: 2. 1 to: abf size do: [ :i | self assert: (abf at: i) = (col at: i) ]. self assert: abf size + 2 = col size! ! !ArrayTest methodsFor: 'tests - subcollections access'! testFirstNElements "self debug: #testFirstNElements" | result | result := self moreThan3Elements first: self moreThan3Elements size - 1. 1 to: result size do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i) ]. self assert: result size = (self moreThan3Elements size - 1). self should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] raise: Error! ! !ArrayTest methodsFor: 'tests - subcollections access'! testLastNElements "self debug: #testLastNElements" | result | result := self moreThan3Elements last: self moreThan3Elements size - 1. 1 to: result size do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i + 1) ]. self assert: result size = (self moreThan3Elements size - 1). self should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ] raise: Error! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ArrayTest class uses: TEmptySequenceableTest classTrait + TSequencedElementAccessTest classTrait + TCloneTest classTrait + TCopyTest classTrait + TSetArithmetic classTrait + TCreationWithTest classTrait + TPutBasicTest classTrait + TConvertTest classTrait + TSortTest classTrait + TIterateSequencedReadableTest classTrait + TSequencedConcatenationTest classTrait + TReplacementSequencedTest classTrait + TAsStringCommaAndDelimiterSequenceableTest classTrait + TBeginsEndsWith classTrait + TPrintOnSequencedTest classTrait + TIndexAccess classTrait + TSubCollectionAccess classTrait + TCopyPartOfSequenceable classTrait + TCopySequenceableSameContents classTrait + TCopySequenceableWithOrWithoutSpecificElements classTrait + TCopySequenceableWithReplacement classTrait + TIndexAccessForMultipliness classTrait + TCopyPartOfSequenceableForMultipliness classTrait + TConvertAsSortedTest classTrait + TPutTest classTrait + TIncludesWithIdentityCheckTest classTrait + TConvertAsSetForMultiplinessIdentityTest classTrait + TSequencedStructuralEqualityTest classTrait + TOccurrencesForMultiplinessTest classTrait instanceVariableNames: ''! SequenceableCollection subclass: #ArrayedCollection instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Abstract'! !ArrayedCollection commentStamp: '' 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." ^ 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: '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: '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: '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: '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: '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: '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: '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 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'! 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'! 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' 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'! 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: '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! ! Halt subclass: #AssertionFailure instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: '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: 'Compiler-ParseNodes'! !AssignmentNode commentStamp: '' prior: 0! AssignmentNode comment: 'I represent a (var_expr) construct.'! !AssignmentNode methodsFor: 'code generation' stamp: 'eem 6/4/2008 11:26'! emitForEffect: stack on: aStream variable emitLoad: stack on: aStream. value emitForValue: stack on: aStream. pc := aStream position + 1. "debug pc is first byte of the store". variable emitStorePop: stack on: aStream! ! !AssignmentNode methodsFor: 'code generation' stamp: 'eem 6/4/2008 11:26'! emitForValue: stack on: aStream variable emitLoad: stack on: aStream. value emitForValue: stack on: aStream. pc := aStream position + 1. "debug pc is first byte of the store" variable emitStore: stack on: aStream! ! !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: 'code generation (closures)' stamp: 'eem 5/30/2008 09:37'! analyseTempsWithin: scopeBlock "" rootNode: rootNode "" assignmentPools: assignmentPools "" "N.B. since assigment happens _after_ the value is evaluated the value is sent the message _first_." value analyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools. variable beingAssignedToAnalyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools! ! !AssignmentNode methodsFor: 'code generation (new scheme)' stamp: 'eem 6/4/2008 11:27'! emitCodeForEffect: stack encoder: encoder variable emitCodeForLoad: stack encoder: encoder. value emitCodeForValue: stack encoder: encoder. pc := encoder methodStreamPosition + 1. "debug pc is first byte of the store, i.e. the next byte". variable emitCodeForStorePop: stack encoder: encoder! ! !AssignmentNode methodsFor: 'code generation (new scheme)' stamp: 'eem 6/4/2008 11:27'! emitCodeForValue: stack encoder: encoder variable emitCodeForLoad: stack encoder: encoder. value emitCodeForValue: stack encoder: encoder. pc := encoder methodStreamPosition + 1. "debug pc is first byte of the store, i.e. the next byte". variable emitCodeForStore: stack encoder: encoder! ! !AssignmentNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/20/2008 15:16'! sizeCodeForEffect: encoder ^(variable sizeCodeForLoad: encoder) + (value sizeCodeForValue: encoder) + (variable sizeCodeForStorePop: encoder)! ! !AssignmentNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/20/2008 15:16'! sizeCodeForValue: encoder ^(variable sizeCodeForLoad: encoder) + (value sizeCodeForValue: encoder) + (variable sizeCodeForStore: encoder)! ! !AssignmentNode methodsFor: 'equation translation'! variable ^variable! ! !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: 'printing' stamp: 'eem 5/6/2008 13:48'! printOn: aStream indent: level variable printOn: aStream indent: level. aStream nextPutAll: ' := '. value printOn: aStream indent: level + 2! ! !AssignmentNode methodsFor: 'printing' stamp: 'eem 5/9/2008 18:44'! printOn: aStream indent: level precedence: p aStream nextPut: $(. self printOn: aStream indent: level. aStream nextPut: $)! ! !AssignmentNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisOn: aStream indent: level variable printWithClosureAnalysisOn: aStream indent: level. aStream nextPutAll: ' := '. value printWithClosureAnalysisOn: aStream indent: level + 2! ! !AssignmentNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisOn: aStream indent: level precedence: p aStream nextPut: $(. self printWithClosureAnalysisOn: aStream indent: level. aStream nextPut: $)! ! !AssignmentNode methodsFor: 'testing' stamp: 'eem 6/16/2008 09:37'! isAssignmentNode ^true! ! !AssignmentNode methodsFor: 'visiting' stamp: 'eem 9/10/2008 15:12'! accept: aVisitor aVisitor visitAssignmentNode: self! ! LookupKey subclass: #Association instanceVariableNames: 'value' classVariableNames: '' poolDictionaries: '' category: 'Collections-Support'! !Association commentStamp: '' 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: '*services-base-preferences' stamp: 'rr 3/21/2006 11:58'! serviceUpdate self key service perform: self value! ! !Association methodsFor: 'accessing' stamp: 'John M McIntosh 3/2/2009 21:15'! 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: '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: 'comparing' stamp: 'md 1/27/2004 17:27'! = anAssociation ^ super = anAssociation and: [value = anAssociation value]! ! !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: '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: 'self evaluating' stamp: 'sd 7/31/2005 21:44'! isSelfEvaluating ^ self class == Association! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Association class instanceVariableNames: ''! !Association class methodsFor: 'instance creation'! key: newKey value: newValue "Answer an instance of me with the arguments as the key and value of the association." ^(super key: newKey) value: newValue! ! ClassTestCase subclass: #AssociationTest instanceVariableNames: 'a b' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Support'! !AssociationTest methodsFor: 'setup' stamp: 'zz 12/5/2005 18:33'! setUp a := 1 -> 'one'. b := 1 -> 'een'.! ! !AssociationTest methodsFor: 'tests' stamp: 'ab 12/29/2008 07:59'! testComparison self assert: ((#a -> 'foo') < (#b -> 'zork'))! ! !AssociationTest methodsFor: 'tests' stamp: 'md 3/8/2004 16:37'! testEquality self assert: (a key = b key); deny: (a value = b value); deny: (a = b) ! ! !AssociationTest methodsFor: 'tests' stamp: 'al 10/13/2008 20:32'! testHash self assert: (a hash = a copy hash); assert: (a hash = b hash)! ! !AssociationTest methodsFor: 'tests' stamp: 'ab 12/29/2008 08:01'! testIsSelfEvaluating self assert: (a isSelfEvaluating). self assert: (a printString = '1->''one''') ! ! Object subclass: #AsyncFile instanceVariableNames: 'name writeable semaphore fileHandle' classVariableNames: 'Busy ErrorCode' poolDictionaries: '' category: 'Files-Kernel'! !AsyncFile commentStamp: '' 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: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:31'! 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: 'ar 6/3/2007 22:13'! 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 asVmPathName forWrite: writeable semaIndex: semaIndex. fileHandle ifNil: [ Smalltalk unregisterExternalObject: semaphore. semaphore := nil. ^ nil]. ! ! !AsyncFile methodsFor: 'as yet unclassified' stamp: 'nice 4/16/2009 10:02'! 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 | buffer := String new: byteCount. self primReadStart: fileHandle fPosition: fPosition count: byteCount. "here's the process that awaits the results:" [| n | [ 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 = ErrorCode ifTrue: [^ self error: 'asynchronous read operation failed']. aBlock value: buffer. ] forkAt: Processor userInterruptPriority. ! ! !AsyncFile methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:31'! 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: 'nice 4/16/2009 10:02'! 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." self primWriteStart: fileHandle fPosition: fPosition fromBuffer: buffer at: 1 count: buffer size. "here's the process that awaits the results:" [| n | [ semaphore wait. n := self primWriteResult: fileHandle. n = Busy. ] whileTrue. "loop while busy in case the semaphore had excess signals" n = ErrorCode 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: 'primitives' stamp: 'ar 2/2/2001 15:09'! primClose: fHandle "Close this file. Do nothing if primitive fails." ! ! !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." ^ 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" 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." 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" 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." writeable ifFalse: [^ self error: 'attempt to write a file opened read-only']. self primitiveFailed ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AsyncFile class instanceVariableNames: ''! !AsyncFile class methodsFor: 'initialization' stamp: 'bootstrap 5/31/2006 20:45'! initialize "AsyncFile initialize" "Possible abnormal I/O completion results." Busy := -1. ErrorCode := -2. ! ! Object subclass: #Author instanceVariableNames: 'fullName' classVariableNames: '' poolDictionaries: '' category: 'System-Support'! !Author commentStamp: 'MiguelCoba 7/25/2009 01:09' prior: 0! I am responsible for the full name used to identify the current code author.! !Author methodsFor: 'accessing' stamp: 'MiguelCoba 7/25/2009 02:41'! fullName "Answer the full name to be used to identify the current code author." [fullName isEmptyOrNil ] whileTrue: [self requestFullName]. ^ fullName! ! !Author methodsFor: 'accessing' stamp: 'MiguelCoba 7/25/2009 00:55'! fullName: aString fullName := aString.! ! !Author methodsFor: 'accessing' stamp: 'MiguelCoba 7/25/2009 00:58'! fullNamePerSe "Answer the currently-prevailing author full name, such as it is, empty or not" ^ fullName! ! !Author methodsFor: 'initialization' stamp: 'MiguelCoba 7/25/2009 03:07'! initialize super initialize. fullName := ''.! ! !Author methodsFor: 'ui-requests' stamp: 'MiguelCoba 9/16/2009 12:10'! messagePrompt ^ 'Please type your full name. It will be used to sign the changes you make to the image. Avoid spaces, accents, dashes, underscore and similar characters. Vincent van Gogh -> VincentVanGogh Miguel Cobá -> MiguelCoba Göran Krampe -> GoranKrampe Göran Krampe -> GoeranKrampe Stéphane DUCASSE -> StephaneDucasse Yoshiki Oshima -> YoshikiOshima '! ! !Author methodsFor: 'ui-requests' stamp: 'MiguelCoba 7/25/2009 01:54'! requestFullName | initialAnswer | initialAnswer := fullName isEmptyOrNil ifTrue: ['FirstnameLastname' translated] ifFalse: [fullName]. fullName := UIManager default request: self messagePrompt initialAnswer: initialAnswer! ! !Author methodsFor: 'testing-support' stamp: 'oscar.nierstrasz 10/18/2009 18:27'! useAuthor: aString during: aBlock | previous | previous := fullName. fullName := aString. ^ aBlock ensure: [ fullName := previous ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Author class instanceVariableNames: 'uniqueInstance'! !Author class methodsFor: 'convenience' stamp: 'MiguelCoba 7/25/2009 01:58'! fullName ^ Author uniqueInstance fullName! ! !Author class methodsFor: 'convenience' stamp: 'MiguelCoba 7/25/2009 01:58'! fullName: aString ^ Author uniqueInstance fullName: aString! ! !Author class methodsFor: 'convenience' stamp: 'MiguelCoba 7/25/2009 01:58'! fullNamePerSe ^ Author uniqueInstance fullNamePerSe! ! !Author class methodsFor: 'convenience' stamp: 'MiguelCoba 7/25/2009 01:10'! requestFullName ^ Author uniqueInstance requestFullName! ! !Author class methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 06:24'! initials self deprecated: 'Use ''Author fullName'' instead.'. ^ Author uniqueInstance fullName! ! !Author class methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 06:25'! initials: aString self deprecated: 'Use ''Author fullName:'' instead.'. ^ Author uniqueInstance fullName: aString! ! !Author class methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 06:25'! initialsPerSe self deprecated: 'Use ''Author fullNamePerSe'' instead.'. ^ Author uniqueInstance fullNamePerSe! ! !Author class methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 06:26'! requestInitials self deprecated: 'Use ''Author requestFullName'' instead.'. ^ Author uniqueInstance requestFullName! ! !Author class methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 06:27'! requestName self deprecated: 'Use ''Author requestFullName'' instead.'. ^ Author uniqueInstance requestFullName! ! !Author class methodsFor: 'instance creation' stamp: 'on 5/10/2008 13:05'! new self error: 'Author is a singleton -- send uniqueInstance instead'! ! !Author class methodsFor: 'instance creation' stamp: 'on 5/10/2008 13:10'! reset ^ uniqueInstance := nil! ! !Author class methodsFor: 'instance creation' stamp: 'on 5/10/2008 13:09'! uniqueInstance ^ uniqueInstance ifNil: [ uniqueInstance := super new ]! ! !Author class methodsFor: 'instance creation' stamp: 'on 5/10/2008 13:27'! uniqueInstance: anInstance "Needed by AuthorTest to restore saved instance" ^ uniqueInstance := anInstance! ! !Author class methodsFor: 'testing-support' stamp: 'oscar.nierstrasz 10/18/2009 18:31'! useAuthor: aString during: aBlock ^ self uniqueInstance useAuthor: aString during: aBlock! ! TestCase subclass: #AuthorTest instanceVariableNames: 'author' classVariableNames: '' poolDictionaries: '' category: 'Tests-System'! !AuthorTest methodsFor: 'running' stamp: 'on 5/10/2008 13:31'! setUp author := Author uniqueInstance. Author reset.! ! !AuthorTest methodsFor: 'running' stamp: 'on 5/10/2008 13:21'! tearDown Author uniqueInstance: author! ! !AuthorTest methodsFor: 'running' stamp: 'on 5/10/2008 14:48'! testDeprecation | savedPref | savedPref := Preferences showDeprecationWarnings. Preferences setPreference: #showDeprecationWarnings toValue: true. self should: [ Utilities authorInitials ] raise: Warning. self should: [ Utilities authorInitialsPerSe ] raise: Warning. self should: [ Utilities setAuthorInitials ] raise: Warning. self should: [ Utilities setAuthorInitials: 'ak' ] raise: Warning. self should: [ Utilities authorName ] raise: Warning. self should: [ Utilities authorName: 'alan' ] raise: Warning. self should: [ Utilities authorNamePerSe ] raise: Warning. self should: [ Utilities setAuthorName ] raise: Warning. Preferences setPreference: #showDeprecationWarnings toValue: savedPref. ! ! !AuthorTest methodsFor: 'running' stamp: 'MiguelCoba 7/25/2009 02:45'! testInitiallyEmpty self assert: (Author uniqueInstance fullNamePerSe isEmpty). ! ! !AuthorTest methodsFor: 'running' stamp: 'on 5/10/2008 13:35'! testUniqueness self should: [ Author new ] raise: Error.! ! Object subclass: #Authorizer instanceVariableNames: 'users realm' classVariableNames: '' poolDictionaries: '' category: 'Network-Url'! !Authorizer commentStamp: '' 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: 'authentication' stamp: 'PeterHugossonMiller 9/3/2009 00:12'! 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 := String new writeStream. [ 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 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 class instanceVariableNames: ''! !Authorizer class methodsFor: 'as yet unclassified' stamp: 'adrian_lienhard 7/18/2009 15:52'! unauthorizedFor: realm ^'HTTP/1.0 401 Unauthorized', self crlf, 'WWW-Authenticate: Basic realm="Pharo/',realm,'"', String crlfcrlf, 'Unauthorized

Unauthorized for ',realm, '

' ! ! Object subclass: #AutoStart instanceVariableNames: 'parameters' classVariableNames: 'Active InstalledLaunchers' poolDictionaries: '' category: 'System-Support'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AutoStart class instanceVariableNames: ''! !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: 'initialization' stamp: 'mir 7/28/1999 17:44'! deinstall "AutoStart deinstall" Smalltalk removeFromStartUpList: AutoStart. InstalledLaunchers := nil! ! !AutoStart class methodsFor: '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: 'initialization' stamp: 'mir 9/30/2004 15:06'! shutDown: quitting self active: false! ! !AutoStart class methodsFor: 'initialization' stamp: 'stephane.ducasse 4/13/2009 21:14'! 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]]]! ! !AutoStart class methodsFor: 'updating' stamp: 'sd 3/20/2008 22:26'! 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: 'sd 3/20/2008 22:26'! 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: 'CdG 10/17/2005 19:34'! 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" | choice | (Preferences valueOfFlag: #updateFromServerAtStartup) ifTrue: [choice := UIManager default chooseFrom: #('Yes, Update' 'No, Not now' 'Don''t ask again') title: 'Shall I look for new code\updates 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! ! !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! ! Object subclass: #BDFFontReader instanceVariableNames: 'file properties' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Fonts'! !BDFFontReader commentStamp: '' 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: 'initialize' stamp: 'alain.plantec 5/28/2009 09:41'! initialize super initialize. properties := Dictionary new.! ! !BDFFontReader methodsFor: 'initialize' stamp: 'pmm 7/4/2009 12:05'! openFileNamed: fileName file := (MultiByteFileStream readOnlyFileNamed: fileName) ascii; wantsLineEndConversion: true; yourself! ! !BDFFontReader methodsFor: 'reading' stamp: 'nop 1/18/2000 19:45'! errorFileFormat self error: 'malformed bdf format'! ! !BDFFontReader methodsFor: 'reading' stamp: 'nop 1/18/2000 19:46'! errorUnsupported self error: 'unsupported bdf'! ! !BDFFontReader methodsFor: 'reading' stamp: 'ar 10/25/2005 00:35'! getLine ^file upTo: Character cr.! ! !BDFFontReader methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:51'! 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 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 := array readStream. 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 := (chars at: i) readStream. 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 := (chars at: i) readStream. form := stream next. encoding := stream next. bbx := stream next. lastAscii + 1 to: encoding - 1 do: [ :a | xTable at: a + 2 put: (xTable at: a + 1) ]. blt copy: ((xTable at: encoding + 1) @ (ascent - (bbx at: 2) - (bbx at: 4)) extent: (bbx at: 1) @ (bbx at: 2)) from: 0 @ 0 in: form. xTable at: encoding + 2 put: (xTable at: encoding + 1) + (bbx at: 1). lastAscii := encoding ] ]. ret := Array new: 8. ret at: 1 put: xTable. ret at: 2 put: glyphs. ret at: 3 put: minAscii. ret at: 4 put: maxAscii. ret at: 5 put: maxWidth. ret at: 6 put: ascent. ret at: 7 put: descent. ret at: 8 put: pointSize. ^ ret " ^{xTable. glyphs. minAscii. maxAscii. maxWidth. ascent. descent. pointSize}"! ! !BDFFontReader methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! readAttributes "I don't handle double-quotes correctly, but it works" | str a | file reset. [ file atEnd ] whileFalse: [ str := self getLine. (str beginsWith: 'STARTCHAR') ifTrue: [ file skip: 0 - str size - 1. ^ self ]. a := str substrings. properties at: a first asSymbol put: a allButFirst ]. self error: 'file seems corrupted'! ! !BDFFontReader methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:51'! readChars | strikeWidth ascent descent minAscii maxAscii maxWidth chars charsNum height form encoding bbx array width pointSize stream | form := encoding := bbx := nil. 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 := array readStream. 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) ]. ^ chars! ! !BDFFontReader methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! readOneCharacter | str a encoding bbx form bits hi low pos | ((str := self getLine) beginsWith: 'ENDFONT') ifTrue: [ ^ { nil. nil. nil } ]. (str beginsWith: 'STARTCHAR') ifFalse: [ self errorFileFormat ]. ((str := self getLine) beginsWith: 'ENCODING') ifFalse: [ self errorFileFormat ]. encoding := Integer readFromString: str substrings second. (self getLine beginsWith: 'SWIDTH') ifFalse: [ self errorFileFormat ]. (self getLine beginsWith: 'DWIDTH') ifFalse: [ self errorFileFormat ]. ((str := self getLine) beginsWith: 'BBX') ifFalse: [ self errorFileFormat ]. a := str substrings. bbx := (2 to: 5) collect: [ :i | Integer readFromString: (a at: i) ]. ((str := self getLine) beginsWith: 'ATTRIBUTES') ifTrue: [ str := self getLine ]. (str beginsWith: 'BITMAP') ifFalse: [ self errorFileFormat ]. form := Form extent: (bbx at: 1) @ (bbx at: 2). bits := form bits. pos := 0. 1 to: (bbx at: 2) do: [ :t | 1 to: ((bbx at: 1) - 1) // 8 + 1 do: [ :i | hi := ('0123456789ABCDEF' indexOf: file next asUppercase) - 1 bitShift: 4. low := ('0123456789ABCDEF' indexOf: file next asUppercase) - 1. bits byteAt: pos + i put: hi + low ]. file next ~= Character cr ifTrue: [ self errorFileFormat ]. pos := pos + (((bbx at: 1) // 32 + 1) * 4) ]. (self getLine beginsWith: 'ENDCHAR') ifFalse: [ self errorFileFormat ]. encoding < 0 ifTrue: [ ^ { nil. nil. nil } ]. ^ { form. encoding. bbx }! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BDFFontReader class instanceVariableNames: ''! !BDFFontReader class methodsFor: 'documentation' stamp: 'nop 2/11/2001 00:22'! gettingAndInstallingTheFonts "Download the 1.3M of BDF font source files from x.org: BDFFontReader downloadFonts. Convert them to .sf2 StrikeFont files: BDFFontReader convertX11FontsToStrike2. Install them into the system as TextStyles: BDFFontReader installX11Fonts. Read the legal notices in 'BDFFontReader x11FontLegalNotices' before redistributing images containing these fonts."! ! !BDFFontReader class methodsFor: 'documentation' stamp: 'nop 1/23/2000 18:30'! x11FontLegalNotices ^ 'The X11 BDF fonts contain copyright and license information as comments in the font source code. For the font family files "cour" (Courier), "helv" (Helvetica), "ncen" (New Century Schoolbook), and "tim" (Times Roman) the notice reads: COMMENT Copyright 1984-1989, 1994 Adobe Systems Incorporated. COMMENT Copyright 1988, 1994 Digital Equipment Corporation. COMMENT COMMENT Adobe is a trademark of Adobe Systems Incorporated which may be COMMENT registered in certain jurisdictions. COMMENT Permission to use these trademarks is hereby granted only in COMMENT association with the images described in this file. COMMENT COMMENT Permission to use, copy, modify, distribute and sell this software COMMENT and its documentation for any purpose and without fee is hereby COMMENT granted, provided that the above copyright notices appear in all COMMENT copies and that both those copyright notices and this permission COMMENT notice appear in supporting documentation, and that the names of COMMENT Adobe Systems and Digital Equipment Corporation not be used in COMMENT advertising or publicity pertaining to distribution of the software COMMENT without specific, written prior permission. Adobe Systems and COMMENT Digital Equipment Corporation make no representations about the COMMENT suitability of this software for any purpose. It is provided "as COMMENT is" without express or implied warranty. For the font family files "char" (Charter), the notice reads: COMMENT Copyright 1988 Bitstream, Inc., Cambridge, Massachusetts, USA COMMENT Bitstream and Charter are registered trademarks of Bitstream, Inc. COMMENT COMMENT The names "Bitstream" and "Charter" are registered trademarks of COMMENT Bitstream, Inc. Permission to use these trademarks is hereby COMMENT granted only in association with the images described in this file. COMMENT COMMENT Permission to use, copy, modify, and distribute this software and COMMENT its documentation for any purpose and without fee is hereby COMMENT granted, provided that the above copyright notice appear in all COMMENT copies and that both that copyright notice and this permission COMMENT notice appear in supporting documentation, and that the name of COMMENT Bitstream not be used in advertising or publicity pertaining to COMMENT distribution of the software without specific, written prior COMMENT permission. Bitstream makes no representations about the COMMENT suitability of this software for any purpose. It is provided "as COMMENT is" without express or implied warranty. COMMENT COMMENT BITSTREAM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, COMMENT INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN COMMENT NO EVENT SHALL BITSTREAM BE LIABLE FOR ANY SPECIAL, INDIRECT OR COMMENT CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS COMMENT OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, COMMENT NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN COMMENT CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. For the font family files "lu" (Lucida), "lub" (Lucida Bright), and "lut" (Lucida Typewriter), the notice reads: COMMENT (c) Copyright Bigelow & Holmes 1986, 1985. Lucida is a registered COMMENT trademark of Bigelow & Holmes. See LEGAL NOTICE file for terms COMMENT of the license. The LEGAL NOTICE contains: This is the LEGAL NOTICE pertaining to the Lucida fonts from Bigelow & Holmes: NOTICE TO USER: The source code, including the glyphs or icons forming a par of the OPEN LOOK TM Graphic User Interface, on this tape and in these files is copyrighted under U.S. and international laws. Sun Microsystems, Inc. of Mountain View, California owns the copyright and has design patents pending on many of the icons. AT&T is the owner of the OPEN LOOK trademark associated with the materials on this tape. Users and possessors of this source code are hereby granted a nonexclusive, royalty-free copyright and design patent license to use this code in individual and commercial software. A royalty-free, nonexclusive trademark license to refer to the code and output as "OPEN LOOK" compatible is available from AT&T if, and only if, the appearance of the icons or glyphs is not changed in any manner except as absolutely necessary to accommodate the standard resolution of the screen or other output device, the code and output is not changed except as authorized herein, and the code and output is validated by AT&T. Bigelow & Holmes is the owner of the Lucida (R) trademark for the fonts and bit-mapped images associated with the materials on this tape. Users are granted a royalty-free, nonexclusive license to use the trademark only to identify the fonts and bit-mapped images if, and only if, the fonts and bit-mapped images are not modified in any way by the user. Any use of this source code must include, in the user documentation and internal comments to the code, notices to the end user as follows: (c) Copyright 1989 Sun Microsystems, Inc. Sun design patents pending in the U.S. and foreign countries. OPEN LOOK is a trademark of AT&T. Used by written permission of the owners. (c) Copyright Bigelow & Holmes 1986, 1985. Lucida is a registered trademark of Bigelow & Holmes. Permission to use the Lucida trademark is hereby granted only in association with the images and fonts described in this file. SUN MICROSYSTEMS, INC., AT&T, AND BIGELOW & HOLMES MAKE NO REPRESENTATIONS ABOUT THE SUITABILITY OF THIS SOURCE CODE FOR ANY PURPOSE. IT IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED WARRANTY OF ANY KIND. SUN MICROSYSTEMS, INC., AT&T AND BIGELOW & HOLMES, SEVERALLY AND INDIVIDUALLY, DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOURCE CODE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. IN NO EVENT SHALL SUN MICROSYSTEMS, INC., AT&T OR BIGELOW & HOLMES BE LIABLE FOR ANY SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES, OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOURCE CODE. '. ! ! !BDFFontReader class methodsFor: 'file creation' stamp: 'nice 4/16/2009 10:04'! convertFilesNamed: fileName toFamilyNamed: familyName inDirectoryNamed: dirName "BDFFontReader convertFilesNamed: 'helvR' toFamilyNamed: 'Helvetica' inDirectoryNamed: '' " "This utility converts X11 BDF font files to Squeak .sf2 StrikeFont files." "For this utility to work as is, the BDF files must be named 'familyNN.bdf', and must reside in the directory named by dirName (use '' for the current directory). The output StrikeFont files will be named familyNN.sf2, and will be placed in the current directory." "Check for matching file names." | allFontNames dir | dir := dirName isEmpty ifTrue: [ FileDirectory default ] ifFalse: [ FileDirectory default directoryNamed: dirName ]. allFontNames := dir fileNamesMatching: fileName , '##.bdf'. allFontNames isEmpty ifTrue: [ ^ self error: 'No files found like ' , fileName , 'NN.bdf' ]. UIManager default informUserDuring: [ :info | allFontNames do: [ :fname | | sizeChars f | info value: 'Converting ' , familyName , ' BDF file ' , fname , ' to SF2 format'. sizeChars := (fname copyFrom: fileName size + 1 to: fname size) copyUpTo: $.. f := StrikeFont new readBDFFromFile: (dir fullNameFor: fname) name: familyName , sizeChars. f writeAsStrike2named: familyName , sizeChars , '.sf2' ] ]! ! !BDFFontReader class methodsFor: 'file creation' stamp: 'yo 5/25/2004 10:52'! new ^ self basicNew. ! ! !BDFFontReader class methodsFor: 'file creation' stamp: 'ar 10/25/2005 00:21'! openFileNamed: fileName ^self new openFileNamed: fileName! ! !BDFFontReader class methodsFor: 'resource download' stamp: 'nop 1/23/2000 18:43'! convertX11FontsToStrike2 "BDFFontReader convertX11FontsToStrike2" "Given a set of standard X11 BDF font files (probably downloaded via BDFFontReader downloadFonts), produce .sf2 format fonts. The source and destination directory is the current directory." "Charter currently tickles a bug in the BDF parser. Skip it for now." "self convertFilesNamed: 'charR' toFamilyNamed: 'Charter' inDirectoryNamed: ''." self convertFilesNamed: 'courR' toFamilyNamed: 'Courier' inDirectoryNamed: ''. self convertFilesNamed: 'helvR' toFamilyNamed: 'Helvetica' inDirectoryNamed: ''. self convertFilesNamed: 'lubR' toFamilyNamed: 'LucidaBright' inDirectoryNamed: ''. self convertFilesNamed: 'luRS' toFamilyNamed: 'Lucida' inDirectoryNamed: ''. self convertFilesNamed: 'lutRS' toFamilyNamed: 'LucidaTypewriter' inDirectoryNamed: ''. self convertFilesNamed: 'ncenR' toFamilyNamed: 'NewCenturySchoolbook' inDirectoryNamed: ''. self convertFilesNamed: 'timR' toFamilyNamed: 'TimesRoman' inDirectoryNamed: ''.! ! !BDFFontReader class methodsFor: 'resource download' stamp: 'pmm 7/4/2009 12:07'! downloadFonts "BDFFontReader downloadFonts" "Download a standard set of BDF sources from x.org. The combined size of these source files is around 1.2M; after conversion to .sf2 format they may be deleted." | heads tails filenames baseUrl basePath | heads := #( 'charR' 'courR' 'helvR' 'lubR' 'luRS' 'lutRS' 'ncenR' 'timR' ). tails := #('08' '10' '12' '14' '18' '24' ). filenames := OrderedCollection new. heads do: [ :head | filenames addAll: (tails collect: [ :tail | head , tail , '.bdf' ]) ]. baseUrl := Url absoluteFromText: 'http://ftp.x.org/pub/R6.4/xc/fonts/bdf/75dpi/'. basePath := baseUrl path. filenames do: [ :filename | | newUrl newPath document f | newUrl := baseUrl clone. newPath := OrderedCollection newFrom: basePath. newPath addLast: filename. newUrl path: newPath. UIManager default informUser: 'Fetching ' translated, filename during: [ document := newUrl retrieveContents ]. f := (MultiByteFileStream newFileNamed: filename) ascii; wantsLineEndConversion: true; yourself. f nextPutAll: document content. f close ]! ! !BDFFontReader class methodsFor: 'resource download' stamp: 'eem 6/11/2008 13:33'! installX11Fonts "BDFFontReader installX11Fonts" "Installs previously-converted .sf2 fonts into the TextConstants dictionary. This makes them available as TextStyles everywhere in the image." | families | families := #( 'Courier' 'Helvetica' 'LucidaBright' 'Lucida' 'LucidaTypewriter' 'NewCenturySchoolbook' 'TimesRoman' ). families do: [:family | | fontArray textStyle | fontArray := StrikeFont readStrikeFont2Family: family. textStyle := TextStyle fontArray: fontArray. TextConstants at: family asSymbol put: textStyle. ]. ! ! ImageReadWriter subclass: #BMPReadWriter instanceVariableNames: 'bfType bfSize bfOffBits biSize biWidth biHeight biPlanes biBitCount biCompression biSizeImage biXPelsPerMeter biYPelsPerMeter biClrUsed biClrImportant' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Files'! !BMPReadWriter methodsFor: 'reading' stamp: 'ar 6/16/2002 15:36'! nextImage | colors | stream binary. self readHeader. biBitCount = 24 ifTrue:[^self read24BmpFile]. "read the color map" colors := self readColorMap. ^self readIndexedBmpFile: colors! ! !BMPReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! read24BmpFile "Read 24-bit pixel data from the given a BMP stream." | form formBits pixelLine bitsIndex bitBlt | form := Form extent: biWidth @ biHeight depth: 32. pixelLine := ByteArray new: (24 * biWidth + 31) // 32 * 4. bitsIndex := (form height - 1) * biWidth + 1. formBits := form bits. 1 to: biHeight do: [ :i | pixelLine := stream nextInto: pixelLine. self read24BmpLine: pixelLine into: formBits startingAt: bitsIndex width: biWidth. bitsIndex := bitsIndex - biWidth ]. bitBlt := BitBlt toForm: form. bitBlt combinationRule: 7. "bitOr:with:" bitBlt halftoneForm: (Bitmap with: 4278190080). bitBlt copyBits. ^ form! ! !BMPReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! read24BmpLine: pixelLine into: formBits startingAt: formBitsIndex width: width | pixIndex rgb bitsIndex | pixIndex := 0. "pre-increment" bitsIndex := formBitsIndex - 1. "pre-increment" 1 to: width do: [ :j | rgb := (pixelLine at: (pixIndex := pixIndex + 1)) + ((pixelLine at: (pixIndex := pixIndex + 1)) bitShift: 8) + ((pixelLine at: (pixIndex := pixIndex + 1)) bitShift: 16). formBits at: (bitsIndex := bitsIndex + 1) put: rgb ]! ! !BMPReadWriter methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:51'! readColorMap "Read colorCount BMP color map entries from the given binary stream. Answer an array of Colors." | colorCount colors maxLevel b g r ccStream | colorCount := (bfOffBits - 54) // 4. "Note: some programs (e.g. Photoshop 4.0) apparently do not set colorCount; assume that any data between the end of the header and the start of the pixel data is the color map" biBitCount >= 16 ifTrue: [ ^ nil ]. colorCount = 0 ifTrue: [ "this BMP file does not have a color map" "default monochrome color map" biBitCount = 1 ifTrue: [ ^ Array with: Color white with: Color black ]. "default gray-scale color map" maxLevel := (2 raisedTo: biBitCount) - 1. ^ (0 to: maxLevel) collect: [ :level | Color gray: level asFloat / maxLevel ] ]. ccStream := (stream next: colorCount * 4) readStream. colors := Array new: colorCount. 1 to: colorCount do: [ :i | b := ccStream next. g := ccStream next. r := ccStream next. ccStream next. "skip reserved" colors at: i put: (Color r: r g: g b: b range: 255) ]. ^ colors! ! !BMPReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! readHeader | reserved | bfType := stream nextLittleEndianNumber: 2. bfSize := stream nextLittleEndianNumber: 4. reserved := stream nextLittleEndianNumber: 4. bfOffBits := stream nextLittleEndianNumber: 4. biSize := stream nextLittleEndianNumber: 4. biWidth := stream nextLittleEndianNumber: 4. biHeight := stream nextLittleEndianNumber: 4. biPlanes := stream nextLittleEndianNumber: 2. biBitCount := stream nextLittleEndianNumber: 2. biCompression := stream nextLittleEndianNumber: 4. biSizeImage := stream nextLittleEndianNumber: 4. biXPelsPerMeter := stream nextLittleEndianNumber: 4. biYPelsPerMeter := stream nextLittleEndianNumber: 4. biClrUsed := stream nextLittleEndianNumber: 4. biClrImportant := stream nextLittleEndianNumber: 4! ! !BMPReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! readIndexedBmpFile: colors "Read uncompressed pixel data of depth d from the given BMP stream, where d is 1, 4, 8, or 16" | form bytesPerRow pixelData pixelLine startIndex map bitBlt mask | colors ifNil: [ form := Form extent: biWidth @ biHeight depth: biBitCount ] ifNotNil: [ form := ColorForm extent: biWidth @ biHeight depth: biBitCount. form colors: colors ]. bytesPerRow := (biBitCount * biWidth + 31) // 32 * 4. pixelData := ByteArray new: bytesPerRow * biHeight. biHeight to: 1 by: -1 do: [ :y | pixelLine := stream next: bytesPerRow. startIndex := (y - 1) * bytesPerRow + 1. pixelData replaceFrom: startIndex to: startIndex + bytesPerRow - 1 with: pixelLine startingAt: 1 ]. form bits copyFromByteArray: pixelData. biBitCount = 16 ifTrue: [ map := ColorMap shifts: #(8 -8 0 0 ) masks: #(255 65280 0 0 ). mask := 2147516416 ]. biBitCount = 32 ifTrue: [ map := ColorMap shifts: #(24 8 -8 -24 ) masks: #(255 65280 16711680 4278190080 ). mask := 4278190080 ]. map ifNotNil: [ bitBlt := BitBlt toForm: form. bitBlt sourceForm: form. bitBlt colorMap: map. bitBlt combinationRule: Form over. bitBlt copyBits ]. mask ifNotNil: [ bitBlt := BitBlt toForm: form. bitBlt combinationRule: 7. "bitOr:with:" bitBlt halftoneForm: (Bitmap with: mask). bitBlt copyBits ]. ^ form! ! !BMPReadWriter methodsFor: 'testing' stamp: 'ar 6/16/2002 15:27'! understandsImageFormat stream size < 54 ifTrue:[^false]. "min size = BITMAPFILEHEADER+BITMAPINFOHEADER" self readHeader. bfType = 19778 "BM" ifFalse:[^false]. biSize = 40 ifFalse:[^false]. biPlanes = 1 ifFalse:[^false]. bfSize <= stream size ifFalse:[^false]. biCompression = 0 ifFalse:[^false]. ^true! ! !BMPReadWriter methodsFor: 'writing' stamp: 'lr 7/4/2009 10:42'! nextPutImage: aForm | bhSize rowBytes rgb data colorValues depth image ppw scanLineLen | depth := aForm depth. [ #(1 4 8 32 ) includes: depth ] whileFalse: [ depth := depth + 1 asLargerPowerOfTwo ]. image := aForm asFormOfDepth: depth. image unhibernate. bhSize := 14. "# bytes in file header" biSize := 40. "info header size in bytes" biWidth := image width. biHeight := image height. biClrUsed := depth = 32 ifTrue: [ 0 ] ifFalse: [ 1 << depth ]. "No. color table entries" bfOffBits := biSize + bhSize + (4 * biClrUsed). rowBytes := ((depth min: 24) * biWidth + 31) // 32 * 4. biSizeImage := biHeight * rowBytes. "Write the file header" stream position: 0. stream nextLittleEndianNumber: 2 put: 19778. "bfType = BM" stream nextLittleEndianNumber: 4 put: bfOffBits + biSizeImage. "Entire file size in bytes" stream nextLittleEndianNumber: 4 put: 0. "bfReserved" stream nextLittleEndianNumber: 4 put: bfOffBits. "Offset of bitmap data from start of hdr (and file)" "Write the bitmap info header" stream position: bhSize. stream nextLittleEndianNumber: 4 put: biSize. "info header size in bytes" stream nextLittleEndianNumber: 4 put: image width. "biWidth" stream nextLittleEndianNumber: 4 put: image height. "biHeight" stream nextLittleEndianNumber: 2 put: 1. "biPlanes" stream nextLittleEndianNumber: 2 put: (depth min: 24). "biBitCount" stream nextLittleEndianNumber: 4 put: 0. "biCompression" stream nextLittleEndianNumber: 4 put: biSizeImage. "size of image section in bytes" stream nextLittleEndianNumber: 4 put: 2800. "biXPelsPerMeter" stream nextLittleEndianNumber: 4 put: 2800. "biYPelsPerMeter" stream nextLittleEndianNumber: 4 put: biClrUsed. stream nextLittleEndianNumber: 4 put: 0. "biClrImportant" biClrUsed > 0 ifTrue: [ "write color map; this works for ColorForms, too" colorValues := image colormapIfNeededForDepth: 32. 1 to: biClrUsed do: [ :i | rgb := colorValues at: i. 0 to: 24 by: 8 do: [ :j | stream nextPut: (rgb >> j bitAnd: 255) ] ] ]. depth < 32 ifTrue: [ "depth = 1, 4 or 8." data := image bits asByteArray. ppw := 32 // depth. scanLineLen := (biWidth + ppw - 1) // ppw * 4. "# of bytes in line" 1 to: biHeight do: [ :i | stream next: scanLineLen putAll: data startingAt: (biHeight - i) * scanLineLen + 1 ] ] ifFalse: [ 1 to: biHeight do: [ :i | data := (image copy: (0 @ (biHeight - i) extent: biWidth @ 1)) bits. 1 to: data size do: [ :j | stream nextLittleEndianNumber: 3 put: (data at: j) ]. 1 to: (data size * 3 + 3) // 4 * 4 - (data size * 3) do: [ :j | stream nextPut: 0 "pad to 32-bits" ] ] ]. stream position = (bfOffBits + biSizeImage) ifFalse: [ self error: 'Write failure' ]. stream close! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BMPReadWriter class instanceVariableNames: ''! !BMPReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:56'! typicalFileExtensions "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" ^#('bmp')! ! !BMPReadWriter class methodsFor: 'testing' stamp: 'ar 6/16/2002 18:55'! displayAllFrom: fd "BMPReadWriter displayAllFrom: FileDirectory default" fd fileNames do:[:fName| (fName endsWith: '.bmp') ifTrue:[ [(Form fromBinaryStream: (fd readOnlyFileNamed: fName)) display. Display forceDisplayUpdate] on: Error do:[:nix|]. ]. ]. fd directoryNames do:[:fdName| self displayAllFrom: (fd directoryNamed: fdName) ].! ! !BMPReadWriter class methodsFor: 'testing' stamp: 'ar 6/16/2002 18:56'! readAllFrom: fd "MessageTally spyOn:[BMPReadWriter readAllFrom: FileDirectory default]" fd fileNames do:[:fName| (fName endsWith: '.bmp') ifTrue:[ [Form fromBinaryStream: (fd readOnlyFileNamed: fName)] on: Error do:[:nix]. ]. ]. fd directoryNames do:[:fdName| self readAllFrom: (fd directoryNamed: fdName) ].! ! TestCase subclass: #BMPReadWriterTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'GraphicsTests-Files'! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 02:22'! bmpData16bit "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest16b.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk24AAAAAAAAADYAAAAoAAAACAAAAAgAAAABABAAAAAAAIIAAADDDgAAww4AAAAAAAAAAAAA 4APgA+AD4AMfAB8AHwAfAOAD4APgA+ADHwAfAB8AHwDgA+AD/3//f/9//38fAB8A4APgA/9/ /3//f/9/HwAfAAAAAAD/f/9//3//fwB8AHwAAAAA/3//f/9//38AfAB8AAAAAAAAAAAAfAB8 AHwAfAAAAAAAAAAAAHwAfAB8AHwAAA==' readStream) contents! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/24/2005 21:27'! bmpData24bit "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest24.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk32AAAAAAAAADYAAAAoAAAACAAAAAgAAAABABgAAAAAAAAAAADEDgAAxA4AAAAAAAAAAAAA AP8AAP8AAP8AAP8A/wAA/wAA/wAA/wAAAP8AAP8AAP8AAP8A/wAA/wAA/wAA/wAAAP8AAP8A /////////////////wAA/wAAAP8AAP8A/////////////////wAA/wAAAAAAAAAA//////// ////////AAD/AAD/AAAAAAAA////////////////AAD/AAD/AAAAAAAAAAAAAAAAAAD/AAD/ AAD/AAD/AAAAAAAAAAAAAAAAAAD/AAD/AAD/AAD/' readStream) contents! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 02:22'! bmpData32bit "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest32b.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk04AQAAAAAAADYAAAAoAAAACAAAAAgAAAABACAAAAAAAAIBAADDDgAAww4AAAAAAAAAAAAA AP8AAAD/AAAA/wAAAP8AAP8AAAD/AAAA/wAAAP8AAAAA/wAAAP8AAAD/AAAA/wAA/wAAAP8A AAD/AAAA/wAAAAD/AAAA/wAA////AP///wD///8A////AP8AAAD/AAAAAP8AAAD/AAD///8A ////AP///wD///8A/wAAAP8AAAAAAAAAAAAAAP///wD///8A////AP///wAAAP8AAAD/AAAA AAAAAAAA////AP///wD///8A////AAAA/wAAAP8AAAAAAAAAAAAAAAAAAAAAAAAA/wAAAP8A AAD/AAAA/wAAAAAAAAAAAAAAAAAAAAAAAAD/AAAA/wAAAP8AAAD/AAAA' readStream) contents! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/24/2005 21:41'! bmpData4bit "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest4.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk12BAAAAAAAADYEAAAoAAAACAAAAAgAAAABAAgAAAAAAEAAAADEDgAAxA4AAAAAAAAAAAAA AAAAAAAAgAAAgAAAAICAAIAAAACAAIAAgIAAAMDAwADA3MAA8MqmAAAgQAAAIGAAACCAAAAg oAAAIMAAACDgAABAAAAAQCAAAEBAAABAYAAAQIAAAECgAABAwAAAQOAAAGAAAABgIAAAYEAA AGBgAABggAAAYKAAAGDAAABg4AAAgAAAAIAgAACAQAAAgGAAAICAAACAoAAAgMAAAIDgAACg AAAAoCAAAKBAAACgYAAAoIAAAKCgAACgwAAAoOAAAMAAAADAIAAAwEAAAMBgAADAgAAAwKAA AMDAAADA4AAA4AAAAOAgAADgQAAA4GAAAOCAAADgoAAA4MAAAODgAEAAAABAACAAQABAAEAA YABAAIAAQACgAEAAwABAAOAAQCAAAEAgIABAIEAAQCBgAEAggABAIKAAQCDAAEAg4ABAQAAA QEAgAEBAQABAQGAAQECAAEBAoABAQMAAQEDgAEBgAABAYCAAQGBAAEBgYABAYIAAQGCgAEBg wABAYOAAQIAAAECAIABAgEAAQIBgAECAgABAgKAAQIDAAECA4ABAoAAAQKAgAECgQABAoGAA QKCAAECgoABAoMAAQKDgAEDAAABAwCAAQMBAAEDAYABAwIAAQMCgAEDAwABAwOAAQOAAAEDg IABA4EAAQOBgAEDggABA4KAAQODAAEDg4ACAAAAAgAAgAIAAQACAAGAAgACAAIAAoACAAMAA gADgAIAgAACAICAAgCBAAIAgYACAIIAAgCCgAIAgwACAIOAAgEAAAIBAIACAQEAAgEBgAIBA gACAQKAAgEDAAIBA4ACAYAAAgGAgAIBgQACAYGAAgGCAAIBgoACAYMAAgGDgAICAAACAgCAA gIBAAICAYACAgIAAgICgAICAwACAgOAAgKAAAICgIACAoEAAgKBgAICggACAoKAAgKDAAICg 4ACAwAAAgMAgAIDAQACAwGAAgMCAAIDAoACAwMAAgMDgAIDgAACA4CAAgOBAAIDgYACA4IAA gOCgAIDgwACA4OAAwAAAAMAAIADAAEAAwABgAMAAgADAAKAAwADAAMAA4ADAIAAAwCAgAMAg QADAIGAAwCCAAMAgoADAIMAAwCDgAMBAAADAQCAAwEBAAMBAYADAQIAAwECgAMBAwADAQOAA wGAAAMBgIADAYEAAwGBgAMBggADAYKAAwGDAAMBg4ADAgAAAwIAgAMCAQADAgGAAwICAAMCA oADAgMAAwIDgAMCgAADAoCAAwKBAAMCgYADAoIAAwKCgAMCgwADAoOAAwMAAAMDAIADAwEAA wMBgAMDAgADAwKAA8Pv/AKSgoACAgIAAAAD/AAD/AAAA//8A/wAAAP8A/wD//wAA////APr6 +vr8/Pz8+vr6+vz8/Pz6+v/////8/Pr6//////z8AAD/////+fkAAP/////5+QAAAAD5+fn5 AAAAAPn5+fk=' readStream) contents! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/24/2005 21:27'! bmpData8bit "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest8.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk12BAAAAAAAADYEAAAoAAAACAAAAAgAAAABAAgAAAAAAEAAAADEDgAAxA4AAAAAAAAAAAAA AAAAAAAAgAAAgAAAAICAAIAAAACAAIAAgIAAAMDAwADA3MAA8MqmAAAgQAAAIGAAACCAAAAg oAAAIMAAACDgAABAAAAAQCAAAEBAAABAYAAAQIAAAECgAABAwAAAQOAAAGAAAABgIAAAYEAA AGBgAABggAAAYKAAAGDAAABg4AAAgAAAAIAgAACAQAAAgGAAAICAAACAoAAAgMAAAIDgAACg AAAAoCAAAKBAAACgYAAAoIAAAKCgAACgwAAAoOAAAMAAAADAIAAAwEAAAMBgAADAgAAAwKAA AMDAAADA4AAA4AAAAOAgAADgQAAA4GAAAOCAAADgoAAA4MAAAODgAEAAAABAACAAQABAAEAA YABAAIAAQACgAEAAwABAAOAAQCAAAEAgIABAIEAAQCBgAEAggABAIKAAQCDAAEAg4ABAQAAA QEAgAEBAQABAQGAAQECAAEBAoABAQMAAQEDgAEBgAABAYCAAQGBAAEBgYABAYIAAQGCgAEBg wABAYOAAQIAAAECAIABAgEAAQIBgAECAgABAgKAAQIDAAECA4ABAoAAAQKAgAECgQABAoGAA QKCAAECgoABAoMAAQKDgAEDAAABAwCAAQMBAAEDAYABAwIAAQMCgAEDAwABAwOAAQOAAAEDg IABA4EAAQOBgAEDggABA4KAAQODAAEDg4ACAAAAAgAAgAIAAQACAAGAAgACAAIAAoACAAMAA gADgAIAgAACAICAAgCBAAIAgYACAIIAAgCCgAIAgwACAIOAAgEAAAIBAIACAQEAAgEBgAIBA gACAQKAAgEDAAIBA4ACAYAAAgGAgAIBgQACAYGAAgGCAAIBgoACAYMAAgGDgAICAAACAgCAA gIBAAICAYACAgIAAgICgAICAwACAgOAAgKAAAICgIACAoEAAgKBgAICggACAoKAAgKDAAICg 4ACAwAAAgMAgAIDAQACAwGAAgMCAAIDAoACAwMAAgMDgAIDgAACA4CAAgOBAAIDgYACA4IAA gOCgAIDgwACA4OAAwAAAAMAAIADAAEAAwABgAMAAgADAAKAAwADAAMAA4ADAIAAAwCAgAMAg QADAIGAAwCCAAMAgoADAIMAAwCDgAMBAAADAQCAAwEBAAMBAYADAQIAAwECgAMBAwADAQOAA wGAAAMBgIADAYEAAwGBgAMBggADAYKAAwGDAAMBg4ADAgAAAwIAgAMCAQADAgGAAwICAAMCA oADAgMAAwIDgAMCgAADAoCAAwKBAAMCgYADAoIAAwKCgAMCgwADAoOAAwMAAAMDAIADAwEAA wMBgAMDAgADAwKAA8Pv/AKSgoACAgIAAAAD/AAD/AAAA//8A/wAAAP8A/wD//wAA////APr6 +vr8/Pz8+vr6+vz8/Pz6+v/////8/Pr6//////z8AAD/////+fkAAP/////5+QAAAAD5+fn5 AAAAAPn5+fk=' readStream) contents! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 14:04'! bmpDataR5G6B5 "This is a BMP file based on BitmapV4Header which is currently unsupported." "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest16-R5G6B5.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk3IAAAAAAAAAEYAAAA4AAAACAAAAAgAAAABABAAAwAAAIIAAADDDgAAww4AAAAAAAAAAAAA APgAAOAHAAAfAAAAAAAAAOAH4AfgB+AHHwAfAB8AHwDgB+AH4AfgBx8AHwAfAB8A4AfgB/// ////////HwAfAOAH4Af//////////x8AHwAAAAAA//////////8A+AD4AAAAAP////////// APgA+AAAAAAAAAAAAPgA+AD4APgAAAAAAAAAAAD4APgA+AD4AAA=' readStream) contents! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 14:04'! bmpDataX4R4G4B4 "This is a BMP file based on BitmapV4Header which is currently unsupported." "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest16-X4R4G4B4.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk3IAAAAAAAAAEYAAAA4AAAACAAAAAgAAAABABAAAwAAAIIAAADDDgAAww4AAAAAAAAAAAAA AA8AAPAAAAAPAAAAAAAAAPAA8ADwAPAADwAPAA8ADwDwAPAA8ADwAA8ADwAPAA8A8ADwAP8P /w//D/8PDwAPAPAA8AD/D/8P/w//Dw8ADwAAAAAA/w//D/8P/w8ADwAPAAAAAP8P/w//D/8P AA8ADwAAAAAAAAAAAA8ADwAPAA8AAAAAAAAAAAAPAA8ADwAPAAA=' readStream) contents! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 14:05'! bmpDataX8R8G8B8 "This is a BMP file based on BitmapV4Header which is currently unsupported." "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest32-X8R8G8B8.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk1IAQAAAAAAAEYAAAA4AAAACAAAAAgAAAABACAAAwAAAAIBAADDDgAAww4AAAAAAAAAAAAA AAAA/wAA/wAA/wAAAAAAAAAA/wAAAP8AAAD/AAAA/wAA/wAAAP8AAAD/AAAA/wAAAAD/AAAA /wAAAP8AAAD/AAD/AAAA/wAAAP8AAAD/AAAAAP8AAAD/AAD///8A////AP///wD///8A/wAA AP8AAAAA/wAAAP8AAP///wD///8A////AP///wD/AAAA/wAAAAAAAAAAAAAA////AP///wD/ //8A////AAAA/wAAAP8AAAAAAAAAAAD///8A////AP///wD///8AAAD/AAAA/wAAAAAAAAAA AAAAAAAAAAAAAAD/AAAA/wAAAP8AAAD/AAAAAAAAAAAAAAAAAAAAAAAAAP8AAAD/AAAA/wAA AP8AAA==' readStream) contents! ! !BMPReadWriterTest methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:57'! testBmp16Bit | reader form | reader := BMPReadWriter new on: self bmpData16bit readStream. form := reader nextImage. "special black here to compensate for zero-is-transparent effect" self assert: (form colorAt: 7 @ 1) = Color red. self assert: (form colorAt: 1 @ 7) = Color green. self assert: (form colorAt: 7 @ 7) = Color blue. self assert: (form colorAt: 4 @ 4) = Color white. self assert: (form pixelValueAt: 1 @ 1) = 32768! ! !BMPReadWriterTest methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:57'! testBmp24Bit | reader form | reader := BMPReadWriter new on: self bmpData24bit readStream. form := reader nextImage. self assert: (form colorAt: 7 @ 1) = Color red. self assert: (form colorAt: 1 @ 7) = Color green. self assert: (form colorAt: 7 @ 7) = Color blue. self assert: (form colorAt: 4 @ 4) = Color white. self assert: (form pixelValueAt: 1 @ 1) = 4278190080! ! !BMPReadWriterTest methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:57'! testBmp32Bit | reader form | reader := BMPReadWriter new on: self bmpData32bit readStream. form := reader nextImage. self assert: (form colorAt: 7 @ 1) = Color red. self assert: (form colorAt: 1 @ 7) = Color green. self assert: (form colorAt: 7 @ 7) = Color blue. self assert: (form colorAt: 4 @ 4) = Color white. self assert: (form pixelValueAt: 1 @ 1) = 4278190080! ! !BMPReadWriterTest methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:57'! testBmp4Bit | reader form | reader := BMPReadWriter new on: self bmpData4bit readStream. form := reader nextImage. self assert: (form colorAt: 1 @ 1) = Color black. self assert: (form colorAt: 7 @ 1) = Color red. self assert: (form colorAt: 1 @ 7) = Color green. self assert: (form colorAt: 7 @ 7) = Color blue. self assert: (form colorAt: 4 @ 4) = Color white! ! !BMPReadWriterTest methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:57'! testBmp8Bit | reader form | reader := BMPReadWriter new on: self bmpData8bit readStream. form := reader nextImage. self assert: (form colorAt: 1 @ 1) = Color black. self assert: (form colorAt: 7 @ 1) = Color red. self assert: (form colorAt: 1 @ 7) = Color green. self assert: (form colorAt: 7 @ 7) = Color blue. self assert: (form colorAt: 4 @ 4) = Color white! ! Object subclass: #BadEqualer instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SUnit-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: 'SUnit-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: '' 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: 'accessing' stamp: 'md 1/20/2006 15:58'! valuesAndCounts ^ contents! ! !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: '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 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: '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: 'removing' stamp: 'nice 9/14/2009 20:28'! removeAll "Implementation Note: as contents will be overwritten, a shallowCopy of self would be modified. An alternative implementation preserving capacity would be to create a new contents: self setContents: (self class contentsClass new: contents size)." contents removeAll! ! !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: 'private' stamp: 'sma 5/12/2000 14:49'! setContents: aDictionary contents := aDictionary! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 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 "! ! CollectionRootTest subclass: #BagTest uses: TAddTest + TIncludesWithIdentityCheckTest + TCloneTest + TCopyTest + TSetArithmetic + TConvertTest + TAsStringCommaAndDelimiterTest + TRemoveForMultiplenessTest + TPrintTest + TConvertAsSortedTest + TConvertAsSetForMultiplinessTest + TConcatenationTest + TStructuralEqualityTest + TCreationWithTest - {#testOfSize} + TOccurrencesForMultiplinessTest instanceVariableNames: 'empty nonEmpty result emptyButAllocatedWith20 elementExistsTwice element collectionWithElement collectionIn collectionNotIn collectionOfString elementNotIn collectionWithCharacters otherCollectionWithoutEqualElements collectionWithoutNilMoreThan5' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Unordered'! !BagTest methodsFor: 'as yet unclassified' stamp: 'damienpollet 1/13/2009 15:57'! testAnySastify self assert: ( self collection anySatisfy: [:each | each = self element]). self deny: (self collection anySatisfy: [:each | each isString]).! ! !BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:28'! testAdd "self run: #testAdd" "self debug: #testAdd" | aBag | aBag := Bag new. aBag add: 'a'. aBag add: 'b'. self assert: aBag size = 2. aBag add: 'a'. self assert: aBag size = 3. self assert: (aBag occurrencesOf: 'a') = 2 ! ! !BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:28'! testAddWithOccurrences "self debug:#testAddWithOccurrences" | aBag | aBag := Bag new. aBag add: 'a' withOccurrences: 3. self assert: (aBag size = 3). ! ! !BagTest methodsFor: 'basic tests' stamp: 'TJ 3/8/2006 08:42'! testAsBag | aBag | aBag := Bag new. self assert: aBag asBag = aBag.! ! !BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:29'! testAsSet | aBag aSet | aBag := Bag new. aBag add:'a' withOccurrences: 4. aBag add:'b' withOccurrences: 2. aSet := aBag asSet. self assert: aSet size = 2. self assert: (aSet occurrencesOf: 'a') = 1 ! ! !BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:30'! testCopy "self run: #testCopy" | aBag newBag | aBag := Bag new. aBag add:'a' withOccurrences: 4. aBag add:'b' withOccurrences: 2. newBag := aBag copy. self assert: newBag = newBag. self assert: newBag asSet size = 2.! ! !BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:32'! testOccurrencesOf "self debug: #testOccurrencesOf" | aBag | aBag := Bag new. aBag add: 'a' withOccurrences: 3. aBag add: 'b'. aBag add: 'b'. aBag add: 'b'. aBag add: 'b'. self assert: (aBag occurrencesOf:'a') = 3. self assert: (aBag occurrencesOf:'b') = 4. self assert: (aBag occurrencesOf:'c') = 0. self assert: (aBag occurrencesOf: nil) =0. aBag add: nil. self assert: (aBag occurrencesOf: nil) =1. ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:01'! anotherElementOrAssociationIn " return an element (or an association for Dictionary ) present in 'collection' " ^ self collection anyOne! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:01'! anotherElementOrAssociationNotIn " return an element (or an association for Dictionary )not present in 'collection' " ^ elementNotIn ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 12:07'! collectionInForIncluding ^ collectionIn ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 12:16'! collectionMoreThan5Elements " return a collection including at least 5 elements" ^ collectionWithoutNilMoreThan5 ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 12:08'! collectionNotIncluded ^ collectionNotIn ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:07'! collectionOfFloat ^ collectionOfString! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 14:22'! collectionWithCharacters ^ collectionWithCharacters .! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 10:22'! collectionWithCopyNonIdentical " return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)" ^ collectionOfString! ! !BagTest methodsFor: 'requirements' stamp: 'sd 1/28/2009 16:32'! collectionWithElement "Returns a collection that already includes what is returned by #element." ^ collectionWithElement! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:24'! collectionWithElementsToRemove ^ collectionIn! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 14:20'! collectionWithEqualElements ^ nonEmpty ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 10:31'! collectionWithSortableElements " return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" ^ nonEmpty ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:27'! collectionWithoutEqualElements ^ otherCollectionWithoutEqualElements! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 12:15'! collectionWithoutNilElements " return a collection that doesn't includes a nil element and that doesn't includes equal elements'" ^ collectionWithoutNilMoreThan5! ! !BagTest methodsFor: 'requirements' stamp: 'damienpollet 1/30/2009 17:32'! element ^ super element! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 14:19'! elementInForIncludesTest ^ self element ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 14:32'! elementInForOccurrences " return an element included in nonEmpty" ^self nonEmpty anyOne.! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 13:40'! elementNotIn ^elementNotIn ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 15:33'! elementTwiceInForOccurrences " return an element included exactly two time in # collectionWithEqualElements" ^ self elementTwiceIn ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 14:19'! elementsCopyNonIdenticalWithoutEqualElements " return a collection that does niot incllude equal elements ( classic equality ) all elements included are elements for which copy is not identical to the element " ^ collectionOfString ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:53'! firstCollection " return a collection that will be the first part of the concatenation" ^ nonEmpty ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:27'! integerCollectionWithoutEqualElements ^ otherCollectionWithoutEqualElements! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/30/2009 10:54'! nonEmpty1Element ^ self speciesClass new add: self element ;yourself.! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:28'! nonEmptyWithoutEqualElements " return a collection without equal elements " ^ otherCollectionWithoutEqualElements ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:27'! otherCollection ^ otherCollectionWithoutEqualElements! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 11:47'! resultForCollectElementsClass " return the retsult expected by collecting the class of each element of collectionWithoutNilElements" ^ result ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:53'! secondCollection " return a collection that will be the second part of the concatenation" ^ collectionWithCharacters ! ! !BagTest methodsFor: 'requirements' stamp: 'damienpollet 1/30/2009 17:40'! selectedNumber ^ 4! ! !BagTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/6/2008 17:39'! speciesClass ^ Bag! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 14:21'! withEqualElements " return a collection including equal elements (classic equality)" ^ nonEmpty .! ! !BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/6/2008 17:22'! collection ^ nonEmpty. ! ! !BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/5/2008 15:13'! empty ^ empty ! ! !BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/6/2008 17:26'! emptyButAllocatedWith20 ^ emptyButAllocatedWith20! ! !BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/5/2008 15:14'! nonEmpty ^ nonEmpty ! ! !BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/6/2008 17:22'! result ^ result. ! ! !BagTest methodsFor: 'setup' stamp: 'delaunay 5/14/2009 12:15'! setUp empty := self speciesClass new. nonEmpty := self speciesClass new add: 13; add: -2; add: self elementTwiceIn; add: 10; add: self elementTwiceIn; add: self element; yourself. elementNotIn := 0. collectionIn := self speciesClass new add: -2; add: self elementTwiceIn; add: 10; yourself. collectionNotIn := self speciesClass new add: self elementNotIn; add: 5; yourself. collectionOfString := self speciesClass new add: 1.5; add: 5.5; add: 7.5; yourself. otherCollectionWithoutEqualElements := self speciesClass new add: 1; add: 20; add: 30; add: 40; yourself. collectionWithoutNilMoreThan5 := self speciesClass new add: 1; add: 2; add: 3; add: 4; add: 5; add: 6; yourself. result := self speciesClass new add: SmallInteger; add: SmallInteger; add: SmallInteger; add: SmallInteger; add: SmallInteger; add: SmallInteger; yourself. emptyButAllocatedWith20 := self speciesClass new: 20. collectionWithElement := self speciesClass new add: self element; yourself. collectionWithCharacters := self speciesClass new add: $p; add: $v; add: $i; add: $y; yourself! ! !BagTest methodsFor: 'setup' stamp: 'delaunay 5/11/2009 11:27'! sizeCollection ^ otherCollectionWithoutEqualElements! ! !BagTest methodsFor: 'test - copy' stamp: 'delaunay 4/17/2009 15:26'! elementToAdd ^ 42! ! !BagTest methodsFor: 'test - creation'! testWith "self debug: #testWith" | aCol element | element := self collectionMoreThan5Elements anyOne. aCol := self collectionClass with: element. self assert: (aCol includes: element).! ! !BagTest methodsFor: 'test - creation'! testWithAll "self debug: #testWithAll" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection . aCol := self collectionClass withAll: collection . collection do: [ :each | self assert: (aCol occurrencesOf: each ) = ( collection occurrencesOf: each ) ]. self assert: (aCol size = collection size ).! ! !BagTest methodsFor: 'test - creation'! testWithWith "self debug: #testWithWith" | aCol collection element1 element2 | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 2 . element1 := collection at: 1. element2 := collection at:2. aCol := self collectionClass with: element1 with: element2 . self assert: (aCol occurrencesOf: element1 ) == ( collection occurrencesOf: element1). self assert: (aCol occurrencesOf: element2 ) == ( collection occurrencesOf: element2). ! ! !BagTest methodsFor: 'test - creation'! testWithWithWith "self debug: #testWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom:1 to: 3 . aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !BagTest methodsFor: 'test - creation'! testWithWithWithWith "self debug: #testWithWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 4. aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: ( collection at: 4). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !BagTest methodsFor: 'test - creation'! testWithWithWithWithWith "self debug: #testWithWithWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 5 . aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: (collection at: 4 ) with: ( collection at: 5 ). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !BagTest methodsFor: 'test - equality'! testEqualSign "self debug: #testEqualSign" self deny: (self empty = self nonEmpty).! ! !BagTest methodsFor: 'test - equality'! testEqualSignIsTrueForNonIdenticalButEqualCollections "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" self assert: (self empty = self empty copy). self assert: (self empty copy = self empty). self assert: (self empty copy = self empty copy). self assert: (self nonEmpty = self nonEmpty copy). self assert: (self nonEmpty copy = self nonEmpty). self assert: (self nonEmpty copy = self nonEmpty copy).! ! !BagTest methodsFor: 'test - equality'! testEqualSignOfIdenticalCollectionObjects "self debug: #testEqualSignOfIdenticalCollectionObjects" self assert: (self empty = self empty). self assert: (self nonEmpty = self nonEmpty). ! ! !BagTest methodsFor: 'test - iterate' stamp: 'damienpollet 1/30/2009 17:36'! doWithoutNumber ^ 4! ! !BagTest methodsFor: 'test - iterate' stamp: 'marcus.denker 2/20/2009 16:29'! expectedElementByDetect ^ -2 ! ! !BagTest methodsFor: 'test - iterate' stamp: 'damienpollet 1/30/2009 17:37'! expectedSizeAfterReject ^ 2! ! !BagTest methodsFor: 'test - remove' stamp: 'damienpollet 1/30/2009 17:15'! elementTwiceIn ^ super elementTwiceIn! ! !BagTest methodsFor: 'test - remove' stamp: 'damienpollet 1/30/2009 17:07'! testRemoveElementThatExistsTwice "self debug: #testRemoveElementThatDoesExistsTwice" | size | size := self nonEmpty size. self assert: (self nonEmpty includes: self elementTwiceIn). self nonEmpty remove: self elementTwiceIn. self assert: size - 1 = self nonEmpty size! ! !BagTest methodsFor: 'test - set arithmetic' stamp: 'stephane.ducasse 12/20/2008 22:46'! collectionClass ^ Bag! ! !BagTest methodsFor: 'tests' stamp: 'stephane.ducasse 5/20/2009 18:02'! testCreation "self run: #testCreation" "self debug: #testCreation" | bag | bag := Bag new. self assert: (bag size) = 0. self assert: (bag isEmpty). ! ! !BagTest methodsFor: 'tests' stamp: 'stephane.ducasse 5/20/2009 18:02'! testCumulativeCounts "self run: #testCumulativeCounts" "self debug: #testCumulativeCounts" | bag cumulativeCounts | bag := Bag new. bag add: '1' withOccurrences: 50. bag add: '2' withOccurrences: 40. bag add: '3' withOccurrences: 10. cumulativeCounts := bag cumulativeCounts. self assert: cumulativeCounts size = 3. self assert: cumulativeCounts first = (50 -> '1'). self assert: cumulativeCounts second = (90 -> '2'). self assert: cumulativeCounts third = (100 -> '3'). ! ! !BagTest methodsFor: 'tests' stamp: 'stephane.ducasse 5/20/2009 18:02'! testEqual "(self run: #testEqual)" "(self debug: #testEqual)" | bag1 bag2 | bag1 := Bag new. bag2 := Bag new. self assert: bag1 = bag2. bag1 add: #a; add: #b. bag2 add: #a; add: #a. self deny: bag1 = bag2. self assert: bag1 = bag1. bag1 add: #a. bag2 add: #b. self assert: bag1 = bag2. bag1 add: #c. self deny: bag1 = bag2. bag2 add: #c. self assert: bag1 = bag2! ! !BagTest methodsFor: 'tests' stamp: 'stephane.ducasse 5/20/2009 18:03'! testRemove "self run: #testRemove" "self debug: #testRemove" | bag item | item := 'test item'. bag := Bag new. bag add: item. self assert: (bag size) = 1. bag remove: item. self assert: bag isEmpty. bag add: item withOccurrences: 2. bag remove: item. bag remove: item. self assert: (bag size) = 0. self should: [bag remove: item.] raise: Error.! ! !BagTest methodsFor: 'tests' stamp: 'nice 9/14/2009 21:05'! testRemoveAll "Allows one to remove all elements of a collection" | c1 c2 s2 | c1 := #(10 9 8 7 5 4 4 2) asBag. c2 := c1 copy. s2 := c2 size. c1 removeAll. self assert: c1 size = 0. self assert: c2 size = s2 description: 'the copy has not been modified'.! ! !BagTest methodsFor: 'tests' stamp: 'stephane.ducasse 5/20/2009 18:03'! testSortedCounts "self run: #testSortedCounts" "self debug: #testSortedCounts" | bag sortedCounts| bag := Bag new. bag add: '1' withOccurrences: 10. bag add: '2' withOccurrences: 1. bag add: '3' withOccurrences: 5. sortedCounts := bag sortedCounts. self assert: sortedCounts size = 3. self assert: sortedCounts first = (10->'1'). self assert: sortedCounts second = (5->'3'). self assert: sortedCounts third = (1->'2'). ! ! !BagTest methodsFor: 'tests' stamp: 'stephane.ducasse 5/20/2009 18:03'! testSortedElements "self run: #testSortedElements" "self debug: #testSortedElements" | bag sortedElements| bag := Bag new. bag add: '2' withOccurrences: 1. bag add: '1' withOccurrences: 10. bag add: '3' withOccurrences: 5. sortedElements := bag sortedElements. self assert: sortedElements size = 3. self assert: sortedElements first = ('1'->10). self assert: sortedElements second = ('2'->1). self assert: sortedElements third = ('3'->5). ! ! !BagTest methodsFor: 'tests - adding'! testTAdd | added collection | collection :=self otherCollection . added := collection add: self element. self assert: added == self element. "test for identiy because #add: has not reason to copy its parameter." self assert: (collection includes: self element) . self assert: (self collectionWithElement includes: self element). ! ! !BagTest methodsFor: 'tests - adding'! testTAddAll | added collection toBeAdded | collection := self collectionWithElement . toBeAdded := self otherCollection . added := collection addAll: toBeAdded . self assert: added == toBeAdded . "test for identiy because #addAll: has not reason to copy its parameter." self assert: (collection includesAllOf: toBeAdded )! ! !BagTest methodsFor: 'tests - adding'! testTAddIfNotPresentWithElementAlreadyIn | added oldSize collection element | collection := self collectionWithElement . oldSize := collection size. element := self element . self assert: (collection includes: element ). added := collection addIfNotPresent: element . self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." self assert: collection size = oldSize! ! !BagTest methodsFor: 'tests - adding'! testTAddIfNotPresentWithNewElement | added oldSize collection element | collection := self otherCollection . oldSize := collection size. element := self element . self deny: (collection includes: element ). added := collection addIfNotPresent: element . self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." self assert: (collection size = (oldSize + 1)). ! ! !BagTest methodsFor: 'tests - adding'! testTAddTwice | added oldSize collection element | collection := self collectionWithElement . element := self element . oldSize := collection size. added := collection add: element ; add: element . self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." self assert: (collection includes: element ). self assert: collection size = (oldSize + 2)! ! !BagTest methodsFor: 'tests - adding'! testTAddWithOccurences | added oldSize collection element | collection := self collectionWithElement . element := self element . oldSize := collection size. added := collection add: element withOccurrences: 5. self assert: added == element. "test for identiy because #add: has not reason to copy its parameter." self assert: (collection includes: element). self assert: collection size = (oldSize + 5)! ! !BagTest methodsFor: 'tests - adding'! testTWrite | added collection element | collection := self otherCollection . element := self element . added := collection write: element . self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." self assert: (collection includes: element ) . self assert: (collection includes: element ). ! ! !BagTest methodsFor: 'tests - adding'! testTWriteTwice | added oldSize collection element | collection := self collectionWithElement . element := self element . oldSize := collection size. added := collection write: element ; write: element . self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." self assert: (collection includes: element ). self assert: collection size = (oldSize + 2)! ! !BagTest methodsFor: 'tests - as set tests'! testAsIdentitySetWithEqualsElements | result collection | collection := self withEqualElements . result := collection asIdentitySet. collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. self assert: result class = IdentitySet.! ! !BagTest methodsFor: 'tests - as set tests'! testAsSetWithEqualsElements | result | result := self withEqualElements asSet. self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. self assert: result class = Set! ! !BagTest methodsFor: 'tests - as sorted collection'! testAsSortedArray | result collection | collection := self collectionWithSortableElements . result := collection asSortedArray. self assert: (result class includesBehavior: Array). self assert: result isSorted. self assert: result size = collection size! ! !BagTest methodsFor: 'tests - as sorted collection'! testAsSortedCollection | aCollection result | aCollection := self collectionWithSortableElements . result := aCollection asSortedCollection. self assert: (result class includesBehavior: SortedCollection). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = aCollection size.! ! !BagTest methodsFor: 'tests - as sorted collection'! testAsSortedCollectionWithSortBlock | result tmp | result := self collectionWithSortableElements asSortedCollection: [:a :b | a > b]. self assert: (result class includesBehavior: SortedCollection). result do: [ :each | self assert: (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = self collectionWithSortableElements size. tmp:=result at: 1. result do: [:each| self assert: tmp>=each. tmp:=each]. ! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! testAsCommaStringEmpty self assert: self empty asCommaString = ''. self assert: self empty asCommaStringAnd = ''. ! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! testAsCommaStringMore | result resultAnd index allElementsAsString tmp | result:= self nonEmpty asCommaString . resultAnd:= self nonEmpty asCommaStringAnd . tmp :=OrderedCollection new. self nonEmpty do: [ :each | tmp add: each asString]. "verifying result :" index := 1. allElementsAsString := (result findBetweenSubStrs: ', ' ). allElementsAsString do: [:each | self assert: (tmp occurrencesOf: each)=(allElementsAsString occurrencesOf: each). ]. "verifying esultAnd :" allElementsAsString:=(resultAnd findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) | i= allElementsAsString size ifTrue: [self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i))]. i=(allElementsAsString size-1) ifTrue:[ self assert: (allElementsAsString at:i)=('and')]. ].! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! testAsCommaStringOne self nonEmpty1Element do: [:each | self assert: each asString =self nonEmpty1Element asCommaString. self assert: each asString=self nonEmpty1Element asCommaStringAnd.]. ! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! testAsStringOnDelimiterEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim. self assert: emptyStream contents = ''. ! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! testAsStringOnDelimiterLastEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim last:'and'. self assert: emptyStream contents = ''. ! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! testAsStringOnDelimiterLastMore | delim multiItemStream result last allElementsAsString tmp | delim := ', '. last := 'and'. result:=''. tmp := self nonEmpty collect: [:each | each asString]. multiItemStream := ReadWriteStream on:result. self nonEmpty asStringOn: multiItemStream delimiter: ', ' last: last. allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) | i= allElementsAsString size ifTrue: [self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i))]. i=(allElementsAsString size-1) ifTrue:[ self assert: (allElementsAsString at:i)=('and')]. ]. ! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! testAsStringOnDelimiterLastOne | delim oneItemStream result | delim := ', '. result:=''. oneItemStream := ReadWriteStream on: result. self nonEmpty1Element asStringOn: oneItemStream delimiter: delim last: 'and'. oneItemStream do: [:each1 | self nonEmpty1Element do: [:each2 |self assert: each1 = (each2 asString) ] ]. ! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! testAsStringOnDelimiterMore | delim multiItemStream result allElementsAsString tmp | delim := ', '. result:=''. tmp:= self nonEmpty collect:[:each | each asString]. multiItemStream := ReadWriteStream on:result. self nonEmpty asStringOn: multiItemStream delimiter: ', '. allElementsAsString := (result findBetweenSubStrs: ', ' ). allElementsAsString do: [:each | self assert: (tmp occurrencesOf: each)=(allElementsAsString occurrencesOf: each). ].! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! testAsStringOnDelimiterOne | delim oneItemStream result | delim := ', '. result:=''. oneItemStream := ReadWriteStream on: result. self nonEmpty1Element asStringOn: oneItemStream delimiter: delim. oneItemStream do: [:each1 | self nonEmpty1Element do: [:each2 |self assert: each1 = (each2 asString) ] ]. ! ! !BagTest methodsFor: 'tests - concatenation'! testConcatenation "| collection1 collection2 result | collection1 := self firstCollection . collection2 := self secondCollection . result := collection1 , collection2. collection1 do:[ :each | self assert: (result includes: each)]. collection2 do:[ :each | self assert: (result includes: each)]." | collection1 collection2 result | collection1 := self firstCollection . collection2 := self secondCollection . result := collection1 , collection2. result do: [ :each | self assert: (result occurrencesOf: each) = (( collection1 occurrencesOf: each ) + ( collection2 occurrencesOf: each ) ). ]. self assert: result size = (collection1 size + collection2 size)! ! !BagTest methodsFor: 'tests - concatenation'! testConcatenationWithDuplicate | collection1 collection2 result | collection1 := self firstCollection . collection2 := self firstCollection . result := collection1 , collection2. result do: [ :each | self assert: (result occurrencesOf: each) = (( collection1 occurrencesOf: each ) + ( collection2 occurrencesOf: each ) ). ]. self assert: result size = (collection1 size * 2)! ! !BagTest methodsFor: 'tests - concatenation'! testConcatenationWithEmpty | result | result := self firstCollection , self empty. self assert: result = self firstCollection! ! !BagTest methodsFor: 'tests - converting'! assertNoDuplicates: aCollection whenConvertedTo: aClass | result | result := self collectionWithEqualElements asIdentitySet. self assert: (result class includesBehavior: IdentitySet). self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) = 1 ]! ! !BagTest methodsFor: 'tests - converting'! assertNonDuplicatedContents: aCollection whenConvertedTo: aClass | result | result := aCollection perform: ('as' , aClass name) asSymbol. self assert: (result class includesBehavior: aClass). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. ^ result! ! !BagTest methodsFor: 'tests - converting'! assertSameContents: aCollection whenConvertedTo: aClass | result | result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. self assert: result size = aCollection size! ! !BagTest methodsFor: 'tests - converting'! testAsArray "self debug: #testAsArray3" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Array! ! !BagTest methodsFor: 'tests - converting'! testAsByteArray | res | self shouldnt: [self integerCollectionWithoutEqualElements ] raise: Error. self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger] . res := true. self integerCollectionWithoutEqualElements detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! ! !BagTest methodsFor: 'tests - converting'! testAsIdentitySet "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: IdentitySet. ! ! !BagTest methodsFor: 'tests - converting'! testAsOrderedCollection self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! !BagTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! testCopyEmptyWith "self debug: #testCopyWith" | res | res := self empty copyWith: self elementToAdd. self assert: res size = (self empty size + 1). self assert: (res includes: self elementToAdd)! ! !BagTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! testCopyEmptyWithout "self debug: #testCopyEmptyWithout" | res | res := self empty copyWithout: self elementToAdd. self assert: res size = self empty size. self deny: (res includes: self elementToAdd)! ! !BagTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:24'! testCopyEmptyWithoutAll "self debug: #testCopyEmptyWithoutAll" | res | res := self empty copyWithoutAll: self collectionWithElementsToRemove. self assert: res size = self empty size. self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! ! !BagTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! testCopyNonEmptyWith "self debug: #testCopyNonEmptyWith" | res | res := self nonEmpty copyWith: self elementToAdd. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self assert: (res includes: self elementToAdd). self nonEmpty do: [ :each | res includes: each ]! ! !BagTest methodsFor: 'tests - copy'! testCopyNonEmptyWithout "self debug: #testCopyNonEmptyWithout" | res anElementOfTheCollection | anElementOfTheCollection := self nonEmpty anyOne. res := (self nonEmpty copyWithout: anElementOfTheCollection). "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self deny: (res includes: anElementOfTheCollection). self nonEmpty do: [:each | (each = anElementOfTheCollection) ifFalse: [self assert: (res includes: each)]]. ! ! !BagTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:24'! testCopyNonEmptyWithoutAll "self debug: #testCopyNonEmptyWithoutAll" | res | res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]. self nonEmpty do: [ :each | (self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! ! !BagTest methodsFor: 'tests - copy' stamp: 'delaunay 3/30/2009 10:33'! testCopyNonEmptyWithoutAllNotIncluded ! ! !BagTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! testCopyNonEmptyWithoutNotIncluded "self debug: #testCopyNonEmptyWithoutNotIncluded" | res | res := self nonEmpty copyWithout: self elementToAdd. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! !BagTest methodsFor: 'tests - copy - clone'! testCopyCreatesNewObject "self debug: #testCopyCreatesNewObject" | copy | copy := self nonEmpty copy. self deny: self nonEmpty == copy. ! ! !BagTest methodsFor: 'tests - copy - clone'! testCopyEmpty "self debug: #testCopyEmpty" | copy | copy := self empty copy. self assert: copy isEmpty.! ! !BagTest methodsFor: 'tests - copy - clone'! testCopyNonEmpty "self debug: #testCopyNonEmpty" | copy | copy := self nonEmpty copy. self deny: copy isEmpty. self assert: copy size = self nonEmpty size. self nonEmpty do: [:each | copy includes: each]! ! !BagTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/17/2009 15:26'! test0CopyTest self shouldnt: self empty raise: Error. self assert: self empty size = 0. self shouldnt: self nonEmpty raise: Error. self assert: (self nonEmpty size = 0) not. self shouldnt: self collectionWithElementsToRemove raise: Error. self assert: (self collectionWithElementsToRemove size = 0) not. self shouldnt: self elementToAdd raise: Error! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureAsStringCommaAndDelimiterTest self shouldnt: [self nonEmpty] raise:Error . self deny: self nonEmpty isEmpty. self shouldnt: [self empty] raise:Error . self assert: self empty isEmpty. self shouldnt: [self nonEmpty1Element ] raise:Error . self assert: self nonEmpty1Element size=1.! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureCloneTest self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty. ! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureConcatenationTest self shouldnt: [ self firstCollection ]raise: Error. self deny: self firstCollection isEmpty. self shouldnt: [ self firstCollection ]raise: Error. self deny: self firstCollection isEmpty. self shouldnt: [ self empty ]raise: Error. self assert: self empty isEmpty! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureConverAsSortedTest self shouldnt: [self collectionWithSortableElements ] raise: Error. self deny: self collectionWithSortableElements isEmpty .! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureCreationWithTest self shouldnt: [ self collectionMoreThan5Elements ] raise: Error. self assert: self collectionMoreThan5Elements size >= 5.! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureIncludeTest | elementIn | self shouldnt: [ self nonEmpty ]raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self elementNotIn ]raise: Error. elementIn := true. self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ elementIn := false ]. self assert: elementIn = false. self shouldnt: [ self anotherElementNotIn ]raise: Error. elementIn := true. self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ elementIn := false ]. self assert: elementIn = false. self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty. ! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureIncludeWithIdentityTest | element | self shouldnt: [ self collectionWithCopyNonIdentical ]raise: Error. element := self collectionWithCopyNonIdentical anyOne. self deny: element == element copy. ! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureOccurrencesForMultiplinessTest | cpt element collection | self shouldnt: [self collectionWithEqualElements ]raise: Error. self shouldnt: [self collectionWithEqualElements ]raise: Error. self shouldnt: [ self elementTwiceInForOccurrences ] raise: Error. element := self elementTwiceInForOccurrences . collection := self collectionWithEqualElements . cpt := 0 . " testing with identity check ( == ) so that identy collections can use this trait : " self collectionWithEqualElements do: [ :each | each == self elementTwiceInForOccurrences ifTrue: [ cpt := cpt + 1 ] ]. self assert: cpt = 2.! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureOccurrencesTest | tmp | self shouldnt: [self empty ]raise: Error. self assert: self empty isEmpty. self shouldnt: [ self collectionWithoutEqualElements ] raise: Error. self deny: self collectionWithoutEqualElements isEmpty. tmp := OrderedCollection new. self collectionWithoutEqualElements do: [ :each | self deny: (tmp includes: each). tmp add: each. ]. self shouldnt: [ self elementNotInForOccurrences ] raise: Error. self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! ! !BagTest methodsFor: 'tests - fixture'! test0FixturePrintTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty.! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureRequirementsOfTAddTest self shouldnt: [ self collectionWithElement ] raise: Exception. self shouldnt: [ self otherCollection ] raise: Exception. self shouldnt: [ self element ] raise: Exception. self assert: (self collectionWithElement includes: self element). self deny: (self otherCollection includes: self element)! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureSetAritmeticTest self shouldnt: [ self collection ] raise: Error. self deny: self collection isEmpty. self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self anotherElementOrAssociationNotIn ] raise: Error. self collection isDictionary ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. self shouldnt: [ self collectionClass ] raise: Error! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureTConvertAsSetForMultiplinessTest "a collection with equal elements:" | res | self shouldnt: [ self withEqualElements] raise: Error. res := true. self withEqualElements detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = true. ! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureTConvertTest "a collection of number without equal elements:" | res | self shouldnt: [ self collectionWithoutEqualElements ]raise: Error. res := true. self collectionWithoutEqualElements detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. ! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureTRemoveTest | duplicate | self shouldnt: [ self empty ]raise: Error. self shouldnt: [ self nonEmptyWithoutEqualElements] raise:Error. self deny: self nonEmptyWithoutEqualElements isEmpty. duplicate := true. self nonEmptyWithoutEqualElements detect: [:each | (self nonEmptyWithoutEqualElements occurrencesOf: each) > 1] ifNone: [duplicate := false]. self assert: duplicate = false. self shouldnt: [ self elementNotIn ] raise: Error. self assert: self empty isEmpty. self deny: self nonEmptyWithoutEqualElements isEmpty. self deny: (self nonEmptyWithoutEqualElements includes: self elementNotIn)! ! !BagTest methodsFor: 'tests - fixture'! test0TStructuralEqualityTest self shouldnt: [self empty] raise: Error. self shouldnt: [self nonEmpty] raise: Error. self assert: self empty isEmpty. self deny: self nonEmpty isEmpty.! ! !BagTest methodsFor: 'tests - includes' stamp: 'stephane.ducasse 11/21/2008 14:58'! anotherElementNotIn ^ 42! ! !BagTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! elementNotInForOccurrences ^ 666! ! !BagTest methodsFor: 'tests - includes' stamp: 'delaunay 4/28/2009 10:22'! testIdentityIncludes " test the comportement in presence of elements 'includes' but not 'identityIncludes' " " can not be used by collections that can't include elements for wich copy doesn't return another instance " | collection element | self shouldnt: [ self collectionWithCopyNonIdentical ] raise: Error. collection := self collectionWithCopyNonIdentical. element := collection anyOne copy. "self assert: (collection includes: element)." self deny: (collection identityIncludes: element)! ! !BagTest methodsFor: 'tests - includes'! testIdentityIncludesNonSpecificComportement " test the same comportement than 'includes: ' " | collection | collection := self nonEmpty . self deny: (collection identityIncludes: self elementNotIn ). self assert:(collection identityIncludes: collection anyOne) ! ! !BagTest methodsFor: 'tests - includes'! testIncludesAllOfAllThere "self debug: #testIncludesAllOfAllThere'" self assert: (self empty includesAllOf: self empty). self assert: (self nonEmpty includesAllOf: { self nonEmpty anyOne }). self assert: (self nonEmpty includesAllOf: self nonEmpty).! ! !BagTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! testIncludesAllOfNoneThere "self debug: #testIncludesAllOfNoneThere'" self deny: (self empty includesAllOf: self collection). self deny: (self nonEmpty includesAllOf: { (self elementNotIn). (self anotherElementNotIn) })! ! !BagTest methodsFor: 'tests - includes'! testIncludesAnyOfAllThere "self debug: #testIncludesAnyOfAllThere'" self deny: (self nonEmpty includesAnyOf: self empty). self assert: (self nonEmpty includesAnyOf: { self nonEmpty anyOne }). self assert: (self nonEmpty includesAnyOf: self nonEmpty).! ! !BagTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! testIncludesAnyOfNoneThere "self debug: #testIncludesAnyOfNoneThere'" self deny: (self nonEmpty includesAnyOf: self empty). self deny: (self nonEmpty includesAnyOf: { (self elementNotIn). (self anotherElementNotIn) })! ! !BagTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! testIncludesElementIsNotThere "self debug: #testIncludesElementIsNotThere" self deny: (self nonEmpty includes: self elementNotInForOccurrences). self assert: (self nonEmpty includes: self nonEmpty anyOne). self deny: (self empty includes: self elementNotInForOccurrences)! ! !BagTest methodsFor: 'tests - includes'! testIncludesElementIsThere "self debug: #testIncludesElementIsThere" self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! !BagTest methodsFor: 'tests - includes' stamp: 'delaunay 4/9/2009 10:44'! testIncludesSubstringAnywhere "self debug: #testIncludesSubstringAnywher'" self assert: (self empty includesAllOf: self empty). self assert: (self nonEmpty includesAllOf: { (self nonEmpty anyOne) }). self assert: (self nonEmpty includesAllOf: self nonEmpty)! ! !BagTest methodsFor: 'tests - occurrencesOf'! testOccurrencesOfEmpty | result | result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne). self assert: result = 0! ! !BagTest methodsFor: 'tests - occurrencesOf'! testOccurrencesOfNotIn | result | result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences. self assert: result = 0! ! !BagTest methodsFor: 'tests - occurrencesOf for multipliness'! testOccurrencesOfForMultipliness | collection element | collection := self collectionWithEqualElements . element := self elementTwiceInForOccurrences . self assert: (collection occurrencesOf: element ) = 2. ! ! !BagTest methodsFor: 'tests - printing'! testPrintElementsOn | aStream result allElementsAsString tmp | result:=''. aStream:= ReadWriteStream on: result. tmp:= OrderedCollection new. self nonEmpty do: [:each | tmp add: each asString]. self nonEmpty printElementsOn: aStream . allElementsAsString:=(result findBetweenSubStrs: ' ' ). 1 to: allElementsAsString size do: [:i | self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)). ].! ! !BagTest methodsFor: 'tests - printing'! testPrintNameOn | aStream result | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printNameOn: aStream . Transcript show: result asString. self nonEmpty class name first isVowel ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ] ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! ! !BagTest methodsFor: 'tests - printing'! testPrintOn | aStream result allElementsAsString tmp | result:=''. aStream:= ReadWriteStream on: result. tmp:= OrderedCollection new. self nonEmpty do: [:each | tmp add: each asString]. self nonEmpty printOn: aStream . allElementsAsString:=(result findBetweenSubStrs: ' ' ). 1 to: allElementsAsString size do: [:i | i=1 ifTrue:[ self accessCollection class name first isVowel ifTrue:[self assert: (allElementsAsString at:i)='an' ] ifFalse:[self assert: (allElementsAsString at:i)='a'].]. i=2 ifTrue:[self assert: (allElementsAsString at:i)=self accessCollection class name]. i>2 ifTrue:[self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)).]. ].! ! !BagTest methodsFor: 'tests - printing'! testPrintOnDelimiter | aStream result allElementsAsString tmp | result:=''. aStream:= ReadWriteStream on: result. tmp:= OrderedCollection new. self nonEmpty do: [:each | tmp add: each asString]. self nonEmpty printOn: aStream delimiter: ', ' . allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)) ].! ! !BagTest methodsFor: 'tests - printing'! testPrintOnDelimiterLast | aStream result allElementsAsString tmp | result:=''. aStream:= ReadWriteStream on: result. tmp:= OrderedCollection new. self nonEmpty do: [:each | tmp add: each asString]. self nonEmpty printOn: aStream delimiter: ', ' last: 'and'. allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) ifTrue: [self assert: (tmp occurrencesOf: (allElementsAsString at:i))=(allElementsAsString occurrencesOf: (allElementsAsString at:i))]. i=(allElementsAsString size-1) ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString]. i=(allElementsAsString size) ifTrue: [self assert: (tmp occurrencesOf: (allElementsAsString at:i))=(allElementsAsString occurrencesOf: (allElementsAsString at:i))]. ].! ! !BagTest methodsFor: 'tests - printing'! testStoreOn " for the moment work only for collection that include simple elements such that Integer" "| string str result cuttedResult index elementsAsStringExpected elementsAsStringObtained tmp | string := ''. str := ReadWriteStream on: string. elementsAsStringExpected := OrderedCollection new. elementsAsStringObtained := OrderedCollection new. self nonEmpty do: [ :each | elementsAsStringExpected add: each asString]. self nonEmpty storeOn: str. result := str contents . cuttedResult := ( result findBetweenSubStrs: ';' ). index := 1. cuttedResult do: [ :each | index = 1 ifTrue: [ self assert: (each beginsWith: ( tmp := '((' , self nonEmpty class asString , ' new) add: ' )). tmp := each copyFrom: ( tmp size + 1) to: ( each size ). elementsAsStringObtained add: tmp. index := index + 1. ] ifFalse: [ index < cuttedResult size ifTrue:[self assert: (each beginsWith: ( tmp:= ' add: ' )). tmp := each copyFrom: ( tmp size + 1) to: ( each size ). elementsAsStringObtained add: tmp. index := index + 1.] ifFalse: [self assert: ( each = ' yourself)' ) ]. ] ]. elementsAsStringExpected do: [ :each | self assert: (elementsAsStringExpected occurrencesOf: each ) = ( elementsAsStringObtained occurrencesOf: each) ]" ! ! !BagTest methodsFor: 'tests - remove'! testRemoveAllError "self debug: #testRemoveElementThatExists" | el res subCollection | el := self elementNotIn. subCollection := self nonEmptyWithoutEqualElements copyWith: el. self should: [ res := self nonEmptyWithoutEqualElements removeAll: subCollection ] raise: Error! ! !BagTest methodsFor: 'tests - remove'! testRemoveAllFoundIn "self debug: #testRemoveElementThatExists" | el res subCollection | el := self nonEmptyWithoutEqualElements anyOne. subCollection := (self nonEmptyWithoutEqualElements copyWithout: el) copyWith: self elementNotIn. self shouldnt: [ res := self nonEmptyWithoutEqualElements removeAllFoundIn: subCollection ] raise: Error. self assert: self nonEmptyWithoutEqualElements size = 1. self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! !BagTest methodsFor: 'tests - remove'! testRemoveAllSuchThat "self debug: #testRemoveElementThatExists" | el subCollection | el := self nonEmptyWithoutEqualElements anyOne. subCollection := self nonEmptyWithoutEqualElements copyWithout: el. self nonEmptyWithoutEqualElements removeAllSuchThat: [ :each | subCollection includes: each ]. self assert: self nonEmptyWithoutEqualElements size = 1. self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! !BagTest methodsFor: 'tests - remove'! testRemoveElementFromEmpty "self debug: #testRemoveElementFromEmpty" self should: [ self empty remove: self nonEmptyWithoutEqualElements anyOne ] raise: Error! ! !BagTest methodsFor: 'tests - remove'! testRemoveElementReallyRemovesElement "self debug: #testRemoveElementReallyRemovesElement" | size | size := self nonEmptyWithoutEqualElements size. self nonEmptyWithoutEqualElements remove: self nonEmptyWithoutEqualElements anyOne. self assert: size - 1 = self nonEmptyWithoutEqualElements size! ! !BagTest methodsFor: 'tests - remove'! testRemoveElementThatExists "self debug: #testRemoveElementThatExists" | el res | el := self nonEmptyWithoutEqualElements anyOne. self shouldnt: [ res := self nonEmptyWithoutEqualElements remove: el ] raise: Error. self assert: res == el! ! !BagTest methodsFor: 'tests - remove'! testRemoveIfAbsent "self debug: #testRemoveElementThatExists" | el res | el := self elementNotIn. self shouldnt: [ res := self nonEmptyWithoutEqualElements remove: el ifAbsent: [ 33 ] ] raise: Error. self assert: res == 33! ! !BagTest methodsFor: 'tests - set arithmetic'! containsAll: union of: one andOf: another self assert: (one allSatisfy: [:each | union includes: each]). self assert: (another allSatisfy: [:each | union includes: each])! ! !BagTest methodsFor: 'tests - set arithmetic'! numberOfSimilarElementsInIntersection ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! !BagTest methodsFor: 'tests - set arithmetic'! testDifference "Answer the set theoretic difference of two collections." "self debug: #testDifference" self assert: (self collection difference: self collection) isEmpty. self assert: (self empty difference: self collection) isEmpty. self assert: (self collection difference: self empty) = self collection ! ! !BagTest methodsFor: 'tests - set arithmetic'! testDifferenceWithNonNullIntersection "Answer the set theoretic difference of two collections." "self debug: #testDifferenceWithNonNullIntersection" " #(1 2 3) difference: #(2 4) -> #(1 3)" | res overlapping | overlapping := self collectionClass with: self anotherElementOrAssociationNotIn with: self anotherElementOrAssociationIn. res := self collection difference: overlapping. self deny: (res includes: self anotherElementOrAssociationIn). overlapping do: [ :each | self deny: (res includes: each) ]! ! !BagTest methodsFor: 'tests - set arithmetic'! testDifferenceWithSeparateCollection "Answer the set theoretic difference of two collections." "self debug: #testDifferenceWithSeparateCollection" | res separateCol | separateCol := self collectionClass with: self anotherElementOrAssociationNotIn. res := self collection difference: separateCol. self deny: (res includes: self anotherElementOrAssociationNotIn). self assert: res = self collection. res := separateCol difference: self collection. self deny: (res includes: self collection anyOne). self assert: res = separateCol! ! !BagTest methodsFor: 'tests - set arithmetic'! testIntersectionBasic "self debug: #testIntersectionBasic" | inter | inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). self deny: inter isEmpty. self assert: (inter includes: self anotherElementOrAssociationIn value)! ! !BagTest methodsFor: 'tests - set arithmetic'! testIntersectionEmpty "self debug: #testIntersectionEmpty" | inter | inter := self empty intersection: self empty. self assert: inter isEmpty. inter := self empty intersection: self collection . self assert: inter = self empty. ! ! !BagTest methodsFor: 'tests - set arithmetic'! testIntersectionItself "self debug: #testIntersectionItself" self assert: (self collection intersection: self collection) = self collection. ! ! !BagTest methodsFor: 'tests - set arithmetic'! testIntersectionTwoSimilarElementsInIntersection "self debug: #testIntersectionBasic" | inter | inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) = self numberOfSimilarElementsInIntersection. self assert: (inter includes: self anotherElementOrAssociationIn value)! ! !BagTest methodsFor: 'tests - set arithmetic'! testUnion "self debug: #testUnionOfEmpties" | union | union := self empty union: self nonEmpty. self containsAll: union of: self empty andOf: self nonEmpty. union := self nonEmpty union: self empty. self containsAll: union of: self empty andOf: self nonEmpty. union := self collection union: self nonEmpty. self containsAll: union of: self collection andOf: self nonEmpty.! ! !BagTest methodsFor: 'tests - set arithmetic'! testUnionOfEmpties "self debug: #testUnionOfEmpties" self assert: (self empty union: self empty) isEmpty. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BagTest class uses: TAddTest classTrait + TCloneTest classTrait + TCopyTest classTrait + TSetArithmetic classTrait + TConvertTest classTrait + TAsStringCommaAndDelimiterTest classTrait + TRemoveForMultiplenessTest classTrait + TPrintTest classTrait + TConvertAsSortedTest classTrait + TIncludesWithIdentityCheckTest classTrait + TConvertAsSetForMultiplinessTest classTrait + TConcatenationTest classTrait + TStructuralEqualityTest classTrait + TCreationWithTest classTrait + TOccurrencesForMultiplinessTest classTrait instanceVariableNames: ''! 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: '' 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: 'initialization' stamp: 'MarcusDenker 9/30/2009 11:56'! initialize HeightSubdivisions := 0. LineConversions := 0. MonotonSubdivisions := 0. OverflowSubdivisions := 0.! ! Object variableWordSubclass: #BalloonBuffer instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Engine'! !BalloonBuffer commentStamp: '' 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" ^Float fromIEEE32Bit: (self basicAt: index)! ! !BalloonBuffer methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'! floatAt: index put: value "For simulation only" 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'! new ^self new: 256.! ! FormCanvas subclass: #BalloonCanvas instanceVariableNames: 'transform colorTransform engine aaLevel deferred' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Balloon'! !BalloonCanvas commentStamp: '' 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: '*Polymorph-Widgets' stamp: 'gvc 3/21/2008 16:46'! fillRectangle: aRectangle basicFillStyle: aFillStyle "Fill the given rectangle with the given, non-composite, fill style." ^self drawRectangle: aRectangle color: aFillStyle "@@: Name confusion!!!!!!" borderWidth: 0 borderColor: nil ! ! !BalloonCanvas methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 3/21/2008 16:46'! fillRectangle: aRectangle fillStyle: aFillStyle "Fill the given rectangle. Double-dispatched via the fill style." aFillStyle fillRectangle: aRectangle on: self! ! !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: '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: 'converting' stamp: 'ar 11/11/1998 22:57'! asBalloonCanvas ^self! ! !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: '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: '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.! ! !BalloonCanvas methodsFor: 'initialize' stamp: 'ar 11/24/1998 15:28'! flush "Force all pending primitives onscreen" engine ifNotNil:[engine flush].! ! !BalloonCanvas methodsFor: 'initialize' stamp: 'alain.plantec 5/28/2009 09:42'! initialize super initialize. aaLevel := 1. deferred := false.! ! !BalloonCanvas methodsFor: 'initialize' stamp: 'ar 11/11/1998 20:25'! resetEngine engine := nil.! ! !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: '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: 'tween 3/10/2009 07:49'! drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc (self ifNoTransformWithIn: boundsRect) ifTrue:[^super drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc]! ! !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: 'marcus.denker 9/14/2008 21:01'! ifNoTransformWithIn: box "Return true if the current transformation does not affect the given bounding box" | delta | transform ifNil: [^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."! ! Object subclass: #BalloonEdgeData instanceVariableNames: 'index xValue yValue zValue lines source' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Simulation'! !BalloonEdgeData commentStamp: '' prior: 0! BalloonEdgeData defines an entry in the internal edge table of the Balloon engine. Instance Variables: index The index into the external objects array of the associated graphics engine xValue The computed x-value of the requested operation yValue The y-value for the requested operation height The (remaining) height of the edge source