'From Smalltalk-80 version 1.03 of July 31, 1996 on 20 September 1996 at 10:50:05 am'!
Object subclass: #AbstractSound
instanceVariableNames: 'samplesUntilNextControl '
classVariableNames: ''
poolDictionaries: ''
category: 'Sound'!
!AbstractSound methodsFor: 'initialization'!
initialize
^ self
!
setPitch: p dur: d loudness: l
self subclassResponsibility.! !
!AbstractSound methodsFor: 'playing'!
play
"Play this sound to the sound ouput port in real time."
SoundPlayer playSound: self.!
playSampleCount: n into: aSoundBuffer startingAt: startIndex stereo: stereoFlag
"Mixes the next count samples of this sound into the given buffer starting at the given index, updating the receiver's control parameters at periodic intervals."
"Update the control parameters of this sound (e.g., it's envelope)."
"Note: This is only called at a small fraction of the sampling rate."
^ self!
mixSampleCount: count into: aSoundBuffer startingAt: index pan: pan
"Mix the given number of samples with the samples already in the given buffer starting at the given index. Assume that the buffer size is at least (index + count) - 1. The pan parameter determines the left-right balance of the sound, where 0 is left only, 1000 is right only, and 500 is centered."
"Answer the number of samples remaining until the end of this sound. A sound with an indefinite ending time should answer some large integer such as 1000000."
^ 1000000! !
!AbstractSound methodsFor: 'composition'!
+ aSound
"Return the mix of the receiver and the argument sound."
^ MixedSound new
add: self;
add: aSound
!
, aSound
"Return the concatenation of the receiver and the argument sound."
^ SequentialSound new
add: self;
add: aSound
!
delayedBy: seconds
"Return a composite sound consisting of a rest for the given amount of time followed by the receiver."
^ (RestSound dur: seconds), self! !
!AbstractSound methodsFor: 'sampling rates'!
controlRate
"Answer the number of control changes per second."
!AbstractSound class methodsFor: 'instance creation'!
dur: d
"Return a rest of the given duration."
^ self basicNew setDur: d!
namedNoteSequenceFrom: anArray
"Build a note sequence (i.e., a SequentialSound) from the given array. Elements are either (pitchName, duration, loudness) triples or (#rest duration) pairs."
"Build a note sequence (i.e., a SequentialSound) from the given array. Elements are either (pitch, duration, loudness) triples or (#rest duration) pairs."
"Experiment with different settings of the FM modulation and multiplier settings interactively by moving the mouse. The top-left corner of the screen is 0 for both parameters. Stop when the mouse is pressed."
gives an array with true, false, nil, a Point, a Set, and a String
instead of just a bunch of Symbols"
| it |
^ self collect: [:each |
it _ each.
each == #true ifTrue: [it _ true].
each == #false ifTrue: [it _ false].
each == #nil ifTrue: [it _ nil].
each class == String ifTrue: [
it _ Compiler evaluate: each].
each class == Array ifTrue: [it _ it evalStrings].
it]! !
!Array methodsFor: 'printing'!
isLiteral
self detect: [:element | element isLiteral not] ifNone: [^true].
^false!
printOn: aStream
| tooMany |
tooMany _ self maxPrint.
"Need absolute limit, or infinite recursion will never
notice anything going wrong. 7/26/96 tk"
aStream nextPut: $(.
self do:
[:element |
aStream position > tooMany ifTrue: [aStream nextPutAll: '...etc...)'. ^self].
element printOn: aStream.
aStream space].
aStream nextPut: $)!
storeOn: aStream
"Use the literal form if possible."
self isLiteral
ifTrue:
[aStream nextPut: $#; nextPut: $(.
self do:
[:element |
element printOn: aStream.
aStream space].
aStream nextPut: $)]
ifFalse: [super storeOn: aStream]! !
!Array methodsFor: 'private'!
replaceFrom: start to: stop with: replacement startingAt: repStart
"Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
<primitive: 105>
super replaceFrom: start to: stop with: replacement startingAt: repStart! !ArrayedCollection subclass: #Array2D
instanceVariableNames: 'width contents '
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Arrayed'!
!Array2D methodsFor: 'access'!
at: i at: j
"return the element"
(i < 1) | (i > width) ifTrue: [
^ self error: 'first index out of bounds'].
"second index bounds check is automatic, since contents
array will get a bounds error."
^ contents at: (j - 1) * width + i!
at: i at: j add: value
"add value to the element"
| index |
(i < 1) | (i > width) ifTrue: [
^ self error: 'first index out of bounds'].
"second index bounds check is automatic, since contents
array will get a bounds error."
index _ (j - 1) * width + i.
^ contents at: index put: (contents at: index) + value!
at: i at: j put: value
"return the element"
(i < 1) | (i > width) ifTrue: [
^ self error: 'first index out of bounds'].
"second index bounds check is automatic, since contents
array will get a bounds error."
^ contents at: (j - 1) * width + i put: value!
atAllPut: value
"Initialize"
contents atAllPut: value!
atCol: i
"Fetch a whole column. 6/20/96 tk"
| ans |
ans _ contents class new: self height.
1 to: self height do: [:ind |
ans at: ind put: (self at: i at: ind)].
^ ans!
atCol: i put: list
"Put in a whole column.
hold first index constant"
list size = self height ifFalse: [self error: 'wrong size']
'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'!
at: index
self errorNotKeyed!
at: index put: anObject
self errorNotKeyed!
size
| tally |
tally _ 0.
contents do: [:each | tally _ tally + each].
^tally!
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!
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: 'testing'!
includes: anObject
"Refer to the comment in Collection|includes:."
^contents includesKey: anObject!
occurrencesOf: anObject
"Refer to the comment in Collection|occurrencesOf:."
(self includes: anObject)
ifTrue: [^contents at: anObject]
ifFalse: [^0]! !
!Bag methodsFor: 'adding'!
add: newObject
"Refer to the comment in Collection|add:."
^self add: newObject withOccurrences: 1!
add: newObject withOccurrences: anInteger
"Add the element newObject to the receiver. Do so as though the element
were added anInteger number of times. Answer newObject."
"Answer an instance of me containing the same elements as aCollection."
| newCollection |
newCollection _ self new.
newCollection addAll: aCollection.
^newCollection
" Bag newFrom: {1. 2. 3}
{1. 2. 3} as: Bag
"! !Object subclass: #Behavior
instanceVariableNames: 'superclass methodDict format subclasses '
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Classes'!
Behavior comment:
'My instances describe the behavior of other objects. I provide the minimum state necessary for compiling methods, and creating and running instances. Most objects are created as instances of the more fully supported subclass, Class, but I am a good starting point for providing instance-specific behavior (as in Metaclass).'!
!Behavior methodsFor: 'initialize-release'!
obsolete
"Invalidate and recycle local messages. Remove the receiver from its
superclass' subclass list."
methodDict _ MethodDictionary new.
superclass removeSubclass: self! !
!Behavior methodsFor: 'accessing'!
compilerClass
"Answer a compiler class appropriate for source methods of this class."
^Compiler!
confirmRemovalOf: aSelector
"Determine if it is okay to remove the given selector. Answer 1 if it should be removed, 2 if it should be removed followed by a senders browse, and 3 if it should not be removed. 1/17/96 sw
ifTrue: [aFileStream nextChunkPut: (self decompilerClass new
decompile: selector
in: self
method: method) decompileString]
!
firstCommentAt: selector
"Answer a string representing the first comment in the method associated with selector. Return an empty string if the relevant source file is not available, or if the method's source code does not contain a comment. Not smart enough to bypass quotes in string constants, but ""clever"" enough to map doubled quotes into a single quote. 5/1/96 sw"
"Answer an Array of arrays of size 2 whose first element is a message selector in the receiver's method dictionary and whose second element is a set of all message selectors in the method dictionary whose methods send a message with that selector. Subclasses are not included."
'I represent a block transfer (BLT) of pixels into a rectangle (destX, destY, width, height) of the destinationForm. The source of pixels may be a similar rectangle (at sourceX, sourceY) in the sourceForm, or a constant color, currently called halftoneForm. If both are specified, their pixel values are combined with a logical AND function prior to transfer. In any case, the pixels from the source are combined with those of the destination by as specified by the combinationRule.
The combination rule whose value is 0 through 15 programs the transfer to produce 1 or 0 according to its 4-bit representation as follows:
8: if source is 0 and destination is 0
4: if source is 0 and destination is 1
2: if source is 1 and destination is 0
1: if source is 1 and destination is 1.
At each pixel the corresponding bits of the source and destination pixel values determine one of these conditions; if the combination rule has a 1 in the corresponding bit position, then the new destination value will be 1, otherwise it will be zero.
Combination rule 16 is "paint bits". It uses the 1-bit deep sourceForm to cut a hole in the destination. Then it ORs in the sourceForm using the fillColor.
Combination rule 17 is "erase bits". The source Form must be 1 bit deep. It is used to cut a hole (put in zeros) in the destination Form.
Forms may be of different depths, see comment in class Form.
The color specified by halftoneForm may be either a Color or a Pattern. A Color is converted to a pixelValue for the depth of the destinationForm. If a Pattern, BitBlt will simply interpret its bitmap as an array of Color pixelValues. BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary. Within each scan line the 32-bit value is repeated from left to right across the form. If the value repeats on pixels boudaries, the effect will be a constant color; if not, it will produce a halftone that repeats on 32-bit boundaries.
Any transfer specified is further clipped by the specified rectangle (clipX, clipY, clipWidth, clipHeight), and also by the bounds of the source and destination forms.
To make a small Form repeat and fill a big form, use an InfiniteForm as the source.
To write on a form and leave with both transparent and opapue areas, use a MaskedForm as the source.
Pixels from a source to a destination whose pixels have a different depth are converted based on the optional colorMap. If colorMap is nil, then conversion to more bits is done by filling the new high-order bits with zero, and conversion to fewer bits is done by truncating the lost high-order bits. The colorMap, if specified, must be a word array (ie Bitmap) with 2^n elements, where n is the pixel depth of the source. For every source pixel, BitBlt will then index this array, and select the corresponding pixelValue and mask it to the destination pixel size before storing.
When blitting from a 32 or 16 bit deep Form to one 8 bits or less, the default is truncation. This will produce very strange colors, since truncation of the high bits does not produce the nearest encoded color. Supply a 512 long colorMap, and red, green, and blue will be shifted down to 3 bits each, and mapped. The message copybits...stdColors will use the best map to the standard colors for destinations of depths 8, 4, 2 and 1.
Colors can be remapped at the same depth. Sometimes a Form is in terms of colors that are not the standard colors for this depth, for example in a GIF file. Convert the Form to a MaskedForm and send colorMap: the list of colors that the picture is in terms of. MaskedForm will use the colorMap when copying to the display or another Form. (Note also that a Form can be copied to itself, and transformed in the process, if a non-nil colorMap is supplied.)'!
!BitBlt methodsFor: 'accessing'!
clipHeight: anInteger
"Set the receiver's clipping area height to be the argument, anInteger."
clipHeight _ anInteger!
clipRect
"Answer the receiver's clipping area rectangle."
^clipX @ clipY extent: clipWidth @ clipHeight!
clipRect: aRectangle
"Set the receiver's clipping area rectangle to be the argument, aRectangle."
clipX _ aRectangle left.
clipY _ aRectangle top.
clipWidth _ aRectangle width.
clipHeight _ aRectangle height!
clipWidth: anInteger
"Set the receiver's clipping area width to be the argument, anInteger."
clipWidth _ anInteger!
clipX: anInteger
"Set the receiver's clipping area top left x coordinate to be the argument,
anInteger."
clipX _ anInteger!
clipY: anInteger
"Set the receiver's clipping area top left y coordinate to be the argument,
anInteger."
clipY _ anInteger!
colorMap: map
"See last part of BitBlt comment. 6/18/96 tk"
colorMap _ map!
combinationRule: anInteger
"Set the receiver's combination rule to be the argument, anInteger, a
number in the range 0-15."
combinationRule _ anInteger!
destForm
^ destForm!
destOrigin: aPoint
"Set the receiver's destination top left coordinates to be those of the
argument, aPoint."
destX _ aPoint x.
destY _ aPoint y!
destRect: aRectangle
"Set the receiver's destination form top left coordinates to be the origin of
the argument, aRectangle, and set the width and height of the receiver's
destination form to be the width and height of aRectangle."
destX _ aRectangle left.
destY _ aRectangle top.
width _ aRectangle width.
height _ aRectangle height!
destX: anInteger
"Set the top left x coordinate of the receiver's destination form to be the
argument, anInteger."
destX _ anInteger!
destY: anInteger
"Set the top left y coordinate of the receiver's destination form to be the
argument, anInteger."
destY _ anInteger!
fillColor: aColorOrPattern
"The destForm will be filled with this color or pattern of colors. May be an old Color, a new type Color, a Bitmap (see BitBlt comment), a Pattern, or a Form. 6/18/96 tk"
[(BitBlt toForm: Display) copyForm: f to: Sensor cursorPoint rule: Form blend]]!
exampleOne
"This tests BitBlt by displaying the result of all sixteen combination rules that BitBlt is capable of using. (Please see the comment in BitBlt for the meaning of the combination rules)."
| path |
path _ Path new.
0 to: 3 do: [:i | 0 to: 3 do: [:j | path add: j * 100 @ (i * 75)]].
Display fillWhite.
path _ path translateBy: 60 @ 40.
1 to: 16 do: [:index | BitBlt
exampleAt: (path at: index)
rule: index - 1
fillColor: Color gray]
"BitBlt exampleOne"!
exampleTwo
"This is to test painting with a gray tone. It also tests that the seaming with gray patterns is correct in the microcode. Lets you paint for a while and then automatically stops."
| f aBitBlt |
"create a small black Form source as a brush. "
f _ Form extent: 20 @ 20.
f fillBlack.
"create a BitBlt which will OR gray into the display. "
aBitBlt _ BitBlt
destForm: Display
sourceForm: f
fillColor: Color gray
combinationRule: Form under
destOrigin: Sensor cursorPoint
sourceOrigin: 0 @ 0
extent: f extent
clipRect: Display computeBoundingBox.
"paint the gray Form on the screen for a while. "
[Sensor anyButtonPressed] whileFalse:
[aBitBlt destOrigin: Sensor cursorPoint.
aBitBlt copyBits]
"BitBlt exampleTwo"! !
!BitBlt class methodsFor: 'private'!
exampleAt: originPoint rule: rule fillColor: mask
"This builds a source and destination form and copies the source to the
destination using the specifed rule and mask. It is called from the method
named exampleOne."
| s d border aBitBlt |
border_Form extent: 32@32.
border fillBlack.
border fill: (1@1 extent: 30@30) fillColor: Form white.
s _ Form extent: 32@32.
s fillWhite.
s fillBlack: (7@7 corner: 25@25).
d _ Form extent: 32@32.
d fillWhite.
d fillBlack: (0@0 corner: 32@16).
s displayOn: Display at: originPoint.
border displayOn: Display at: originPoint rule: Form under.
d displayOn: Display at: originPoint + (s width @0).
border displayOn: Display at: originPoint + (s width @0) rule: Form under.
d displayOn: Display at: originPoint + (s extent // (2 @ 1)).
'I am a bit-magnifying tool for editing small Forms directly on the display screen. I continue to be active until the user points outside of my viewing area.'!
!BitEditor methodsFor: 'initialize-release'!
initialize
super initialize.
self initializeYellowButtonMenu!
release
super release.
squareForm release.
squareForm _ nil! !
!BitEditor methodsFor: 'view access'!
view: aView
super view: aView.
scale _ aView transformation scale.
scale _ scale x rounded @ scale y rounded.
squareForm _ Form extent: scale depth: aView model depth.
squareForm fillBlack! !
!BitEditor methodsFor: 'basic control sequence'!
controlInitialize
super controlInitialize.
Cursor crossHair show!
controlTerminate
Cursor normal show! !
!BitEditor methodsFor: 'control defaults'!
isControlActive
^super isControlActive & sensor blueButtonPressed not
"show magnified form size until mouse is depressed"
[Sensor redButtonPressed]
whileFalse:
[Display reverse: tempRect.
Display reverse: tempRect.
tempRect _ (Sensor cursorPoint grid: scaleFactor)
extent: tempExtent].
^tempRect! !
BitEditor initialize!
ArrayedCollection variableWordSubclass: #Bitmap
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Graphics-Support'!
Bitmap comment:
'My instances provide contiguous storage of bits, primarily to hold the graphical data of Forms. Forms and their subclasses provide the additional structural information as to how the bits should be interpreted in two dimensions.'!
!Bitmap methodsFor: 'initialize-release'!
fromByteStream: aStream
"Initialize the array of bits by reading integers from the argument,
aStream."
aStream nextInto: self! !
!Bitmap methodsFor: 'filing'!
readCompressedFrom: aStream
"Initialize the array of bits by reading integers from the argument,
aStream."
| pixSize |
pixSize _ aStream next. "1, 2, or 4 bytes"
!
writeCompressedOn: aStream
"Store the array of bits onto the argument, aStream."
aStream nextPutAll: self!
writeOn: aStream
"Store the array of bits onto the argument, aStream."
aStream nextInt32Put: self size.
aStream nextPutAll: self! !
!Bitmap methodsFor: 'printing'!
printOn: aStream
aStream nextPutAll: 'a Bitmap of length '.
self size printOn: aStream! !
!Bitmap methodsFor: 'accessing'!
bitPatternForDepth: depth
"The raw call on BitBlt needs a Bitmap to represent this color. I already am Bitmap like. I am already adjusted for a specific depth. Interpret me as an array of (32/depth) Color pixelValues. BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary. 6/18/96 tk"
^ self!
byteAt: byteAddress
"Extract a byte from a Bitmap. Note that this is a byte address and it is one-order. For repeated use, create an instance of BitBlt and use pixelAt:. See Form pixelAt: 7/1/96 tk"
| lowBits |
lowBits _ byteAddress - 1 bitAnd: 3.
^((self at: byteAddress - 1 - lowBits // 4 + 1)
bitShift: (lowBits - 3) * 8)
bitAnd: 16rFF!
byteAt: byteAddress put: byte
"Insert a byte into a Bitmap. Note that this is a byte address and it is one-order. For repeated use, create an instance of BitBlt and use pixelAt:put:. See Form pixelAt:put: 7/1/96 tk"
replaceFrom: start to: stop with: replacement startingAt: repStart
"Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
<primitive: 105>
super replaceFrom: start to: stop with: replacement startingAt: repStart! !
ifTrue: [^ (self new: len negated) readCompressedFrom: s]
ifFalse: [^ s nextInto: (self new: len)]! !ContextPart variableSubclass: #BlockContext
instanceVariableNames: 'nargs startpc home '
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Methods'!
BlockContext comment:
'My instances function similarly to instances of MethodContext, but they hold the dynamic state for execution of a block in Smalltalk. They access all temporary variables and the method sender via their home pointer, so that those values are effectively shared. Their indexable part is used to store their independent value stack during execution.
My instance must hold onto its home in order to work. This can cause circularities if the home is also pointing (via a temp, perhaps) to the instance. In the rare event that this happens (as in SortedCollection sortBlock:) the message fixTemps will replace home with a copy of home, thus defeating the sharing of temps but, nonetheless, eliminating the circularity.'!
!BlockContext methodsFor: 'initialize-release'!
home: aContextPart startpc: position nargs: anInteger
"This is the initialization message. The receiver has been initialized with
the correct size only."
home _ aContextPart.
startpc _ position.
nargs _ anInteger! !
!BlockContext methodsFor: 'accessing'!
fixTemps
"Fix the values of the temporary variables used in the block that are
ordinarily shared with the method in which the block is defined."
home _ home copy.
home swapSender: nil!
hasMethodReturn
"Answer whether the receiver has a return ('^') in its code."
| method scanner end |
method _ self method.
"Determine end of block from long jump preceding it"
'I represent a bracketed block with 0 or more arguments and 1 or more statements. If I am initialized with no statements, I create one. I have a flag to tell whether my last statement returns a value from the enclosing method. My last three fields remember data needed for code generation. I can emit for value in the usual way, in which case I create a literal method (actually a context remotely copied) to be evaluated by sending it value: at run time. Or I can emit code to be evaluated in line; this only happens at the top level of a method and in conditionals and while-loops, none of which have arguments.'!
'I represent a query path into the class descriptions, the software of the system.'!
!Browser methodsFor: 'initialize-release'!
browserWindowActivated
"Called when a window whose model is the receiver is reactivated, giving the receiver an opportunity to take steps if it wishes. The default is to do nothing. 8/5/96 sw"!
defaultBackgroundColor
^ #lightGreen!
systemOrganizer: aSystemOrganizer
"Initialize the receiver as a perspective on the system organizer,
aSystemOrganizer. Typically there is only one--the system variable
SystemOrganization."
super initialize.
contents _ nil.
systemOrganizer _ aSystemOrganizer.
systemCategoryListIndex _ 0.
classListIndex _ 0.
messageCategoryListIndex _ 0.
messageListIndex _ 0.
metaClassIndicated _ false.
self setClassOrganizer.
editSelection _ #none! !
!Browser methodsFor: 'accessing'!
contents
"Depending on the current selection, different information is retrieved.
Answer a string description of that information. This information is the
method of the currently selected class and message."
"Answer whether the receiver is equipped to browse any class. This is in support of the system-brower feature that allows the browser to be redirected at the selected class name. This implementation is clearly ugly, but the feature it enables is handsome enough. 3/1/96 sw"
self dependents detect:
[:d | d isKindOf: SystemCategoryListView] ifNone: [^ false].
^ true!
doItReceiver
"This class's classPool has been jimmied to be the classPool of the class being browsed. A doIt in the code pane will let the user see the value of the class variables."
^ FakeClassPool new!
editSelection
^editSelection!
request: prompt initialAnswer: initialAnswer
| answer |
FillInTheBlank
request: prompt
displayAt: Sensor cursorPoint
centered: true
action: [:a | answer _ a]
initialAnswer: initialAnswer.
^ answer
!
spawn: aString
"Create and schedule a new browser as though the command browse were
issued with respect to one of the browser's lists. The initial textual
contents is aString, which is the (modified) textual contents of the
'I am a kind of StringHolderController (a ParagraphEditor that adds the doIt, printIt, accept, and cancel commands). I provide control for editing methods in a browser. New commands are:
explain insert an explanation of the current selection just after it
format pretty-print of the code, do not issue an automatic accept
spawn create and schedule a message browser for the, possibly edited but not accepted, code.'!
"Allow class variables and pool variables of current class to be accessed in the inspectIt. 6/13/96 sw"
| result |
model selectedClass == nil ifTrue: [^ super inspectIt].
FakeClassPool classPool: model selectedClass classPool.
FakeClassPool sharedPools: model selectedClass sharedPools.
self controlTerminate.
result _ self evaluateSelection.
FakeClassPool classPool: nil.
FakeClassPool sharedPools: nil.
((result isKindOf: FakeClassPool) or:
[result == #failedDoit])
ifFalse: [result inspect]
ifTrue: [view flash].
self controlInitialize.
^ result!
spawn
"Create and schedule a message browser for the code of the model's
selected message. Retain any edits that have not yet been accepted."
| code |
code _ paragraph text string.
self cancel.
self controlTerminate.
model spawn: code.
self controlInitialize!
spawnIt: characterStream
"Triggered by Cmd-o; spawn a new code window, if it makes sense. Reimplemented by BrowserCodeController 2/1/96 sw. Fixed, 2/5/96 sw, so that it really works."
self controlTerminate.
sensor keyboard.
self spawn.
self controlInitialize.
^ true! !
!BrowserCodeController methodsFor: 'private'!
explainAnySel: symbol
"Is this any message selector?"
| list reply |
list _ Smalltalk allClassesImplementing: symbol.
list size = 0 ifTrue: [^nil].
list size < 12
ifTrue: [reply _ ' is a message selector which is defined in these classes ' , list printString]
ifFalse: [reply _ ' is a message selector which is defined in many classes'].
char = $. ifTrue: [^'"Period marks the end of a Smalltalk statement. A period in the middle of a number means a decimal point. (The number is an instance of Float)."'].
char = $' ifTrue: [^'"The characters between two single quotes are made into an instance of class String"'].
char = $" ifTrue: [^'"Double quotes enclose a comment. Smalltalk ignores everything between double quotes."'].
char = $# ifTrue: [^'"The characters following a hash mark are made into an instance of class Symbol. If parenthesis follow a hash mark, an instance of class Array is made."'].
(char = $( or: [char = $)]) ifTrue: [^'"Expressions enclosed in parenthesis are evaluated first"'].
(char = $[ or: [char = $]]) ifTrue: [^'"The code inside square brackets is an unevaluated block of code. It becomes an instance of BlockContext and is usually passed as an argument."'].
(char = $< or: [char = $>]) ifTrue: [^'"<primitive: xx> means that this method is usually preformed directly by the virtual machine. If this method is primitive, its Smalltalk code is executed only when the primitive fails."'].
char = $^ ifTrue: [^'"Uparrow means return from this method. The value returned is the expression following the ^"'].
char = $| ifTrue: [^'"Vertical bars enclose the names of the temporary variables used in this method. In a block, the vertical bar separates the argument names from the rest of the code."'].
char = $_ ifTrue: [^'"Left arrow means assignment. The value of the expression after the left arrow is stored into the variable before it."'].
char = $; ifTrue: [^'"Semicolon means cascading. The message after the semicolon is sent to the same object which received the message before the semicolon."'].
char = $: ifTrue: [^'"A colon at the end of a keyword means that an argument is expected to follow. Methods which take more than one argument have selectors with more than one keyword. (One keyword, ending with a colon, appears before each argument).', NewLine, NewLine, 'A colon before a variable name just inside a block means that the block takes an agrument. (When the block is evaluated, the argument will be assigned to the variable whose name appears after the colon)."'].
char = $$ ifTrue: [^'"The single character following a dollar sign is made into an instance of class Character"'].
char = $- ifTrue: [^'"A minus sign in front of a number means a negative number."'].
char = $e ifTrue: [^'"An e in the middle of a number means that the exponent follows."'].
char = $r ifTrue: [^'"An r in the middle of a bunch of digits is an instance of Integer expressed in a certain radix. The digits before the r denote the base and the digits after it express a number in that base."'].
char = Character space ifTrue: [^'"the space Character"'].
char = Character tab ifTrue: [^'"the tab Character"'].
char = Character cr ifTrue: [^'"the carriage return Character"'].
^nil!
explainClass: symbol
"Is symbol a class variable or a pool variable?"
| class name pool reply classes |
class _ model selectedClass.
class == nil ifTrue: [^nil]. "no class is selected"
(class isKindOf: Metaclass) ifTrue: [class _ class soleInstance].
classes _ (Array with: class) , class allSuperclasses.
symbol = #nil ifTrue: [reply _ '"is a constant. It is the only instance of class UndefinedObject. nil is the initial value of all variables."'].
symbol = #true ifTrue: [reply _ '"is a constant. It is the only instance of class True and is the receiver of many control messages."'].
symbol = #false ifTrue: [reply _ '"is a constant. It is the only instance of class False and is the receiver of many control messages."'].
model messageListIndex = 0 ifTrue: [^nil]. "no message selected"
symbol = #self
ifTrue:
[classes _ model selectedClassOrMetaClass withAllSubclasses.
classes size > 12
ifTrue: [text _ model selectedClassOrMetaClass printString , ' or a subclass']
ifFalse:
[classes _ classes printString.
text _ 'one of these classes' , (classes copyFrom: 4 to: classes size)].
reply _ '"is the receiver of this message; an instance of ' , text , '"'].
symbol = #super ifTrue: [reply _ '"is just like self. Messages to super are looked up in the superclass (' , model selectedClassOrMetaClass superclass printString , ')"'].
symbol = #thisContext ifTrue: [reply _ '"is a context variable. It''s value is always the MethodContext which is executing this method."'].
^reply!
explainDelimitor: string
"Is string enclosed in delimitors?"
| str |
(string at: 1) isLetter ifTrue: [^nil]. "only special chars"
(string first = string last) ifTrue:
[^ self explainChar: (String with: string first)]
ifFalse:
[(string first = $( and: [string last = $)]) ifTrue:
^'"is a global variable. ' , symbol , ' is a Dictionary. It is a pool which is used by the following classes' , (classes copyFrom: 4 to: classes size) , '"'].
^'"is a global variable. ' , symbol , ' is ' , reply printString , '"'!
explainInst: string
"Is string an instance variable of this class?"
| name each classes |
model selectedClassOrMetaClass == nil ifTrue: [^nil]. "no class is selected"
classes _ (Array with: model selectedClassOrMetaClass)
^ '"' , symbol , ' is a message selector which is defined in ', classes , '. To see the definitions, go to the message list pane and use yellowbug to select ''messages''."'].!
model okToChange "Dont change selection if model is locked"
ifTrue: [^ super redButtonActivity]! !ListView subclass: #BrowserListView
instanceVariableNames: 'singleItemMode '
classVariableNames: ''
poolDictionaries: ''
category: 'Interface-Browser'!
BrowserListView comment:
'I am a ListView whose items are elements of the system, such as class categories or class names. I am abstract; my subclasses provide the connection between items to be viewed and aspects of an instance of Browser.'!
'I am a StandardSystemView that provides initialization methods (messages to myself) to create and schedule the various system browsers: System Browser, System Category Browser, Class Browser, Message Category Browser, Message Browser. The number of subViews I contain depends on which of the browsing functions I am providing.'!
!BrowserView methodsFor: 'emphasis'!
emphasizeSubViews
"Give the model a chance to know that things may have changed behind its back. 8/5/96 sw"
"Create and schedule a BrowserView with the specified window title. The view consists of four subviews, starting with the list view of classes in the SystemOrganization's currently selected system category. The initial text view part is a view of the characters in aString."
aStream position > tooMany ifTrue: [aStream nextPutAll: '...etc...)'. ^self].
element asCharacter printOn: aStream.
aStream space].
aStream nextPut: $)!
replaceFrom: start to: stop with: replacement startingAt: repStart
"Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
<primitive: 105>
super replaceFrom: start to: stop with: replacement startingAt: repStart! !ParseNode subclass: #CascadeNode
instanceVariableNames: 'receiver messages '
classVariableNames: ''
poolDictionaries: ''
category: 'System-Compiler'!
CascadeNode comment: 'The first message has the common receiver, the rest have receiver == nil, which signifies cascading.'!
[self addItem: (ChangeRecord new file: file position: itemPosition type: #method
class: class category: category meta: meta)
text: 'method: ' , class , (meta ifTrue: [' class '] ifFalse: [' ']) , (Parser new parseSelector: method)]!
scanFile: aFile from: startPosition to: stopPosition
| itemPosition item prevChar |
file _ aFile.
changeList _ OrderedCollection new.
list _ OrderedCollection new.
listIndex _ 0.
file position: startPosition.
'Scanning changes...'
displayProgressAt: Sensor cursorPoint
from: startPosition to: stopPosition
during: [:bar |
[file position < stopPosition]
whileTrue:
[bar value: file position.
[file atEnd not and: [file peek isSeparator]]
whileTrue: [prevChar _ file next].
(file peekFor: $!!)
ifTrue:
[prevChar = Character cr ifTrue: [self scanCategory]]
ifFalse:
[itemPosition _ file position.
item _ file nextChunk.
item size > 0 ifTrue:
[self addItem: (ChangeRecord new file: file position: itemPosition type: #doIt)
text: 'do it: ' , (item contractTo: 50)]]]].
listSelections _ Array new: list size withAll: false!
scanVersionsOf: method class: class meta: meta
category: category selector: selector
| sources position prevPos prevFileIndex preamble tokens sourceFilesCopy |
changeList _ OrderedCollection new.
list _ OrderedCollection new.
listIndex _ 0.
position _ method filePosition.
sourceFilesCopy _ SourceFiles collect:
[:x | x isNil ifTrue: [ nil ]
ifFalse: [x readOnlyCopy]].
file _ sourceFilesCopy at: method fileIndex.
[position notNil & file notNil]
whileTrue:
[file position: (0 max: position-150). "Skip back to before the preamble"
[file position < (position-1)] "then pick it up from the front"
whileTrue: [preamble _ file nextChunk].
prevPos _ nil.
(preamble at: (preamble findLast: [:c | c isAlphaNumeric]))
isDigit "Only tokenize if preamble ends with a digit"
ifTrue: [tokens _ Scanner new scanTokens: preamble]
ifFalse: [tokens _ Array new "ie cant be back ref"].
((tokens size between: 7 and: 8)
and: [(tokens at: tokens size-5) = #methodsFor:])
ifTrue:
[prevPos _ tokens at: tokens size-2.
prevPos = 0
ifTrue: [prevPos _ nil] "Zero means no source"
ifFalse: [prevFileIndex _ tokens last]].
self addItem:
(ChangeRecord new file: file position: position
type: #method class: class name category: category meta: meta)
text: class name , (meta ifTrue: [' class '] ifFalse: [' ']) , selector.
position _ prevPos.
prevPos notNil ifTrue:
[file _ sourceFilesCopy at: prevFileIndex]].
sourceFilesCopy do: [:x | x notNil ifTrue: [x close]].
listSelections _ Array new: list size withAll: false!
toggleListIndex: newListIndex
"2/1/96 sw: removed changed: call, to avoid extra refresh whenever selection changes. The call had been 'self changed: #contents', but everything appears to work fine with it omitted."
self openVersions: changeList name: 'Recent versions of ' , selector!
versionCountForSelector: aSelector class: aClass
"Answer the number of versions known to the system for the given class and method, including the current version. A result of greater than one means that there is at least one superseded version. 6/28/96 sw"
(Smalltalk includesKey: class asSymbol) ifFalse: [^ nil].
methodClass _ Smalltalk at: class asSymbol.
meta ifTrue: [^ methodClass class]
ifFalse: [^ methodClass]!
methodSelector
type == #method ifFalse: [^ nil].
^ Parser new parseSelector: self string!
string
| string |
file openReadOnly.
file position: position.
string _ file nextChunk.
file close.
^ string!
type
^ type! !
!ChangeRecord methodsFor: 'initialization'!
file: f position: p type: t
file _ f.
position _ p.
type _ t!
file: f position: p type: t class: c category: cat meta: m
self file: f position: p type: t.
class _ c.
category _ cat.
meta _ m! !Object subclass: #ChangeSet
instanceVariableNames: 'classChanges methodChanges classRemoves name '
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Support'!
ChangeSet comment:
'My instances keep track of the changes made to a system, so the user can make an incremental fileOut. The order in which changes are made is not remembered.'!
!ChangeSet methodsFor: 'initialize-release'!
initialize
"Reset the receiver to be empty."
self wither. "Avoid duplicate entries in AllChangeSets if initialize gets called twice"
classChanges _ Dictionary new.
methodChanges _ Dictionary new.
classRemoves _ Set new.
name _ ChangeSet defaultName!
isMoribund
"Answer whether the receiver is obsolete and about to die; part of an effort to get such guys cleared out from the change sorter. 2/7/96 sw"
^ name == nil !
wither
"The receiver is to be clobbered. Clear it out. 2/7/96 sw"
classChanges _ nil.
methodChanges _ nil.
classRemoves _ nil.
name _ nil! !
!ChangeSet methodsFor: 'testing'!
classChangeAt: className
"Return what we know about class changes to this class."
"Include indication that a class definition has been changed.
6/10/96 sw: don't accumulate this information for classes that don't want logging
7/12/96 sw: use wantsChangeSetLogging flag"
class wantsChangeSetLogging
ifTrue:
[self atClass: class add: #change]!
changedClasses
"Answer a OrderedCollection of changed or edited classes. Not including removed classes. Sort alphabetically by name."
"Much faster to sort names first, then convert back to classes. Because metaclasses reconstruct their name at every comparison in the sorted collection.
8/91 sw chgd to filter out non-existent classes (triggered by problems with class-renames"
"Include indication that a class comment has been changed."
self atClass: class add: #comment!
convertClassAddsToClassChanges
"1/22/96 sw: as part of a general policy of not storing 'new class' ever, but always having it as a changed class, in order to preserve the specific messages that get changed within this change set, we need to morph existing changesets so that class-adds become class-changes. This has no method senders, but rather is for invocation from a doit.
Note that this adds all the selectors for each added class to the changed method list"
"Remove from the receiver all method changes found in aChangeSet. The intention is facilitate the process of factoring a large set of changes into disjoint change sets. 3/13/96 sw. Note that class-(re)-definition changes are not subtracted out, yet."
"Write out all the changes the receiver knows about this class.
5/15/96 sw: altered to call fileOutClassModifications:on: rather than fileOutClassChanges:on:, so that class headers won't go out as part of this process (they no go out at the beginning of the fileout"
| changes |
"first file out class changes"
self fileOutClassModifications: class on: stream.
"next file out changed methods"
changes _ OrderedCollection new.
(methodChanges at: class name ifAbsent: [^ self]) associationsDo:
[:mAssoc |
mAssoc value = #remove
ifFalse: [changes add: mAssoc key]].
changes isEmpty ifFalse:
[class fileOutChangedMessages: changes on: stream.
stream cr]!
fileOutOn: stream
"Write out all the changes the receiver knows about.
5/15/96 sw: changed such that class headers for all changed classes go out at the beginning of the file."
| classList |
self isEmpty ifTrue: [self notify: 'Warning: no changes to file out'].
[stream emphasis: 5; nextChunkPut: class definition; cr; emphasis: 1].
(self atClass: class includes: #comment) ifTrue:
[class organization putCommentOnFile: stream
numbered: nil moveSource: false.
stream cr].
(self atClass: class includes: #reorganize) ifTrue:
[class fileOutOrganizationOn: stream.
stream cr]!
fileOutClassDefinition: class on: stream
"Write out class definition for the given class on the given stream, if the class definition was added or changed. 5/15/96 sw"
((self atClass: class includes: #add) or: [self atClass: class includes: #change])
ifTrue:
[stream emphasis: 5; nextChunkPut: class definition; cr; emphasis: 1]!
fileOutClassModifications: class on: stream
"Write out class mod-- rename, comment, reorg, remove, on the given stream. Differs from the superseded fileOutClassChanges:on: in that it does not deal with class definitions, and does not file out entire added classes. 5/15/96 sw"
"This class presents a view of a single change set. A DualChangeSorter owns two of me. The name pane across the top has a menu of things to do to the ChangeSet I am currently showing.
Renames of classes are not shown properly. 'Copy to other side' overwrites what was there if the other change set had the same method or class change.
ChangeSorter new open.
ChangeSorter allInstances inspect
"!
defaultBackgroundColor
^ #lightBlue!
initialize
myChangeSet _ Smalltalk changes. "default"
classList _ CngsClassList new.
classList parent: self.
messageList _ CngsMsgList new.
messageList parent: self.
MsgListMenu == nil ifTrue: [self class initialize].
classList list: #().
messageList list: #().
!
open
| topView |
self initialize.
topView _ StandardSystemView new.
topView model: self.
topView label: self label.
topView minimumSize: 360@360.
self openView: topView.
topView controller open "Let the show begin"!
openView: topView
"Create change sorter on one changeSet only. Two of these in a DualChangeSorter."
"Open a message list browser on the new and changed methods in the current change set. 2/2/96 sw"
Smalltalk browseMessageList: myChangeSet changedMessageListAugmented name: 'Methods in Change Set ', myChangeSet name!
browseMessagesWithPriorVersions
"Open a message list browser on the new and changed methods in the current change set which have at least one prior version. Potentially a menu command, though its use is perhaps somewhat obscure, so for the moment I'm only getting at this feature via direct calls to the ChangeSet method, through explicit doIts. 6/28/96 sw"
(AllChangeSets collect: [:each | each name]) asStringWithCr) startUp.
index = 0 ifFalse: [
myChangeSet _ AllChangeSets at: index.
buttonView label: myChangeSet name asParagraph.
buttonView display.
self changed: #set].!
cngSetActivity
"Put up a menu and do what the user says. 1991 tck;
5/9/96 sw: highlight button while mouse down
5/29/96 sw: use different menu for single-change-sorter case"
| index reply |
buttonView displayComplemented.
parent == nil "Single change sorter"
ifTrue:
[reply _ SingleCngSetMenu startUp.
reply == nil ifFalse:
[self perform: reply]]
ifFalse:
[index _ CngSetMenu startUp.
index == 0 ifFalse:
[self perform: (CngSetSelectors at: index)]].
buttonView displayNormal!
copyToOther
"Copy this entire change set into the one on the other side"
"controller controlTerminate."
| other |
other _ (parent other: self) changeSet.
other assimilateAllChangesFoundIn: myChangeSet.
(parent other: self) launch.
"controller controlInitialize"!
fileIntoNewChangeSet
"Obtain a file designation from the user, and file its contents into a new change set whose name is a function of the filename; in the end, leave the current change-set unaltered. 5/30/96 sw."
| aFileName aNewChangeSet |
aFileName _ FillInTheBlank request: 'Name of file to be imported: '.
!ChangeSorter class methodsFor: 'as yet unclassified'!
changeSetNamed: aName
"Return the change set of the given name, or nil if none found. 1/22/96 sw"
self gatherChangeSets.
AllChangeSets do:
[:aChangeSet | aChangeSet name = aName ifTrue:
[^ aChangeSet]].
^ nil!
gatherChangeSets
"Collect any change sets created in other projects 1/22/96 sw
2/7/96 sw: filter out moribund guys"
ChangeSet allInstancesDo: [:each |
(AllChangeSets includes: each) ifFalse:
[AllChangeSets add: each]].
^ AllChangeSets _ AllChangeSets select:
[:each | each isMoribund not]
"ChangeSorter gatherChangeSets"!
initialize
"Initialize the class. 1991-tck
Modified 1/12/96 sw: added a bunch of new items, not all of them implemented yet. 2/2/96 sw: added browse change set. Also made it such that if AllChangeSets already exists, this won't clobber the existing order. 2/5/96 sw: changed wording of some items
5/8/96 sw: added subtractOtherSide
5/29/96 sw: added SingleCngSetMenu, for single change sorter
5/30/96 sw: added fileIntoNewChangeSet
7/23/96 di: removed SingleCngSetMenu, since not used"
[:each | each model parent class == ChangeSorter ifTrue: [
each yellowButtonMenu: ClassMenu
yellowButtonMessages: ClassSelectors.
each yellowButtonMenu: MsgListMenu
yellowButtonMessages: MsgListSelectors]].
"!
makeCurrent: aChangeSet
"Make aChangeSet be the one that changes will accumulate into. 5/30/96 sw"
Smalltalk newChanges: aChangeSet!
newChangesFromFile: aFileName
"File in the code from the file of the given name, into a new change set whose name is derived from that of the filename. Leave the 'current change set' unchanged. Returns the new change set; Returns nil on failure. 5/30/96 sw"
| newName aNewChangeSet existingChanges |
existingChanges _ Smalltalk changes.
newName _ aFileName sansPeriodSuffix.
(self changeSetNamed: newName) ~~ nil
ifTrue:
[self inform: 'Sorry -- "', newName, '" is already used as a change-set name'.
^ nil].
aNewChangeSet _ ChangeSet new initialize.
aNewChangeSet name: newName.
AllChangeSets add: aNewChangeSet.
self makeCurrent: aNewChangeSet.
(FileStream oldFileNamed: aFileName) fileIn.
Transcript cr; show: 'File ', aFileName, ' successfully filed in to change set ', newName.
self makeCurrent: existingChanges.
^ aNewChangeSet!
newChangesFromFileStream: aFileStream
"File in the code from the file, into a new change set whose name is derived from the filename. Leave the 'current change set' unchanged. Returns the new change set; Returns nil on failure. 7/12/96 sw"
[self inform: 'Sorry -- "', newName, '" is already used as a change-set name'.
aFileStream close.
^ nil].
aNewChangeSet _ ChangeSet new initialize.
aNewChangeSet name: newName.
AllChangeSets add: aNewChangeSet.
self makeCurrent: aNewChangeSet.
aFileStream fileIn.
Transcript cr; show: 'File ', aFileName, ' successfully filed in to change set ', newName.
self makeCurrent: existingChanges.
^ aNewChangeSet! !
ChangeSorter initialize!
Magnitude subclass: #Character
instanceVariableNames: 'value '
classVariableNames: 'CharacterTable '
poolDictionaries: ''
category: 'Collections-Text'!
Character comment:
'I represent a character by storing its associated ASCII code (extended to 256 codes). My instances are created uniquely, so that all instances of a character ($R, for example) are identical.'!
!Character methodsFor: 'accessing'!
asciiValue
"Answer the value of the receiver that represents its ascii encoding."
^value!
digitValue
"Answer 0-9 if the receiver is $0-$9, 10-35 if it is $A-$Z or $a-$z, and < 0
otherwise. This is used to parse literal numbers of radix 2-36."
'My instances are used to scan text to compute the CharacterBlock for a character specified by its index in the text or its proximity to the cursor location.'!
!CharacterBlockScanner methodsFor: 'scanning'!
characterBlockAtPoint: aPoint in: aParagraph
"Answer a CharacterBlock for character in aParagraph at point aPoint. It
is assumed that aPoint has been transformed into coordinates appropriate
to the text's destination form rectangle and the composition rectangle."
super initializeFromParagraph: aParagraph clippedBy: aParagraph clippingRectangle.
instanceVariableNames: 'lastIndex xTable stopConditions text textStyle leftMargin rightMargin font line runStopIndex spaceCount spaceWidth '
classVariableNames: ''
poolDictionaries: 'TextConstants '
category: 'Graphics-Support'!
CharacterScanner comment:
'My instances hold the state associated with scanning text. My subclasses scan characters for specified purposes, such as computing a CharacterBlock or placing characters into Forms.'!
!CharacterScanner methodsFor: 'scanning'!
characterNotInFont
"All fonts have an illegal character to be used when a character is not
within the font's legal range. When characters out of ranged are
encountered in scanning text, then this special character indicates the
appropriate behavior. The character is usually treated as a unary
message understood by a subclass of CharacterScanner."
recognize | prv cdir result features char r s t dir |
"Alan Kay's recognizer as of 1/31/96. This version preserved for historical purposes, and also because it's still called by the not-yet-deployed method recogPar. Within the current image, the recognizer is now called via #recognizeAndDispatch:until:"
"Inits" (p _ Pen new) defaultNib: 1; down.
"for points" pts _ ReadWriteStream on: #().
"Event Loop"
[(Sensor mousePoint x) < 50] whileFalse:
"First-Time" [pts reset.
"will hold features" ftrs _ ''.
(Sensor anyButtonPressed) ifTrue:
[pts nextPut: (bmin _ bmax _ t _ s _ sts _ Sensor mousePoint).
p place: sts. cdir _ nil.
"Each-Time" [Sensor anyButtonPressed] whileTrue:
[
"ink raw input" p goto: (r _ Sensor mousePoint).
"smooth it" s _ (0.5*s) + (0.5*r).
"thin the stream" ((s x - t x) abs > 3 or:[(s y - t y) abs > 3]) ifTrue:
[ pts nextPut: t.
"bounding box" bmin _ bmin min: s. bmax _ bmax max: s.
"get current dir" dir _ (self fourDirsFrom: t to: s). t _ s.
dir ~= ' dot... ' ifTrue: [
"store new dirs" cdir ~= dir ifTrue: [ftrs _ ftrs, (cdir _ dir)]].
"for inked t's" p place: t; go: 1; place: r.
].
"End Each-Time Loop" ].
"Last-Time"
"save last points" pts nextPut: t; nextPut: r.
"find rest of features" features _ self extractFeatures.
"find char..." char _ CharacterDictionary at: features ifAbsent:
"...or get from user" [ result _ FillInTheBlank request:
'Not recognized. type char, or type ~: ', features.
"ignore or..." result = '~' ifTrue: ['']
"...enter new char" ifFalse: [CharacterDictionary at: features put: result. result]].
"control the editor" (char = 'cr' ifTrue: [Transcript cr] ifFalse:
"Recognize characters, and dispatch each one found by evaluating charDispatchBlock; proceed until terminationBlock is true. This method derives directly from Alan's 1/96 #recognize method, but factors out the character dispatch and the termination condition from the main body of the method. 2/2/96 sw. 2/5/96 sw: switch to using a class variable for the character dictionary, and don't put vacuous entries in the dictionary if the user gives an empty response to the prompt, and don't send empty characters onward, and use a variant of the FillInTheBlank that keeps the prompt clear of the working window. 8/17/96 tk: Turn cr, tab, bs into strings so they work.
9/18/96 sw: in this variant, the block for handling unrecognized features is handed in as an argument, so that in some circumstances we can avoid putting up a prompt. unrecognizedFeaturesBlock should be a one-argument block, which is handed in the features and which is expected to return a string which indicates the determined translation -- empty if none."
| prv cdir features char r s t dir |
"Inits" (p _ Pen new) defaultNib: 1; down.
"for points" pts _ ReadWriteStream on: #().
"Event Loop"
[terminationBlock value] whileFalse:
"First-Time" [pts reset.
"will hold features" ftrs _ ''.
(Sensor anyButtonPressed) ifTrue:
[pts nextPut: (bmin _ bmax _ t _ s _ sts _ Sensor mousePoint).
p place: sts. cdir _ nil.
"Each-Time" [Sensor anyButtonPressed] whileTrue:
"ink raw input" [p goto: (r _ Sensor mousePoint).
"smooth it" s _ (0.5*s) + (0.5*r).
"thin the stream" ((s x - t x) abs > 3 or:[(s y - t y) abs > 3]) ifTrue:
[pts nextPut: t.
"bounding box" bmin _ bmin min: s. bmax _ bmax max: s.
"get current dir" dir _ (self fourDirsFrom: t to: s). t _ s.
dir ~= ' dot... ' ifTrue:
"store new dirs" [cdir ~= dir ifTrue: [ftrs _ ftrs, (cdir _ dir)]].
"for inked t's" p place: t; go: 1; place: r]].
"End Each-Time Loop"
"Last-Time"
"save last points" pts nextPut: t; nextPut: r.
"find rest of features" features _ self extractFeatures.
"find char..." char _ CharacterDictionary at: features ifAbsent:
[unrecognizedFeaturesBlock value: features].
"special chars" char size > 0 ifTrue:
[char = 'tab' ifTrue: [char _ Tab].
char = 'cr' ifTrue: [char _ CR].
"must be a string" char class == Character ifTrue:
[char _ String with: char].
char = 'bs' ifTrue: [char _ BS].
"control the editor" charDispatchBlock value: char]]]
'My instances describe the representation and behavior of objects. I add more comprehensive programming support facilities to the basic attributes of Behavior and the descriptive facilities of ClassDescription. An example is accessing shared (pool) variables.'!
!Class methodsFor: 'initialize-release'!
declare: varString
"Declare class variables common to all instances. Answer whether
recompilation is advisable."
| newVars conflicts assoc class |
newVars _
(Scanner new scanFieldNames: varString)
collect: [:x | x asSymbol].
newVars do:
[:var | var first isLowercase
ifTrue: [self error: var, ' class variable name should be capitalized; proceed to include anyway.']].
!ClassCategoryReader class methodsFor: 'instance creation'!
class: aClass category: aCategory
"Answer an instance of me for the category, aCategory, of the class,
aClass."
^self new setClass: aClass category: aCategory! !ClassCategoryReader subclass: #ClassCompiledCategoryReader
instanceVariableNames: ''
classVariableNames: 'NewMethods '
poolDictionaries: ''
category: 'Kernel-Support'!
ClassCompiledCategoryReader comment:
'A ClassCompiledCategoryReader reads a series of compiled methods stored in the following format and terminated by an extra $!!.
<header word>!!<byte codes in hex>!!
<literal storeStrings each terminated by a space>
!!<method selector>!!<source code>!!
See Behavior<storeLiteral:on: to explain ##<global name> and ###< class name>.
When the file name ends with .f.st, this format is produced by the method ClassDescriptio<printMethodChunk:on:moveSource:toFile:. Also see ClassDescription<printCategoryChunk:on:.
CompiledMethods are not installed when read. Instead, they are added to a collection NewMethods (a class variable) whose elements are arrays of the form
{class. category. selector. compiledMethod}. Later in the file (after all classes and methods have been defined, but before calls on initialize methods have been made), there should be a call on:
ClassCompiledCategoryReader installNewMethods.
This call is produced by the methods ChangeSet<fileOutOn: and ReadWriteStream<fileOutChangesFor: when the file name ends with .f.st'!
"Copied from browseInstVarRefs. Should be consolidated some day. 7/29/96 di
7/30/96 sw: did the consolidation"
self chooseInstVarThenDo:
[:aVar | self browseAllStoresInto: aVar]!
browseInstVarRefs
"1/16/96 sw: moved here from Browser so that it could be used from a variety of places.
7/30/96 sw: call chooseInstVarThenDo: to get the inst var choice"
self chooseInstVarThenDo:
[:aVar | self browseAllAccessesTo: aVar]!
chooseInstVarThenDo: aBlock
"Put up a menu of all the instance variables in the receiver, and when the user chooses one, evaluate aBlock with the chosen variable as its parameter. 7/30/96 sw"
| lines labelStream vars allVars index |
lines _ OrderedCollection new.
allVars _ OrderedCollection new.
labelStream _ WriteStream on: (String new: 200).
self withAllSuperclasses reverseDo:
[:class |
vars _ class instVarNames.
vars do:
[:var |
labelStream nextPutAll: var; cr.
allVars add: var].
vars isEmpty ifFalse: [lines add: allVars size]].
labelStream isEmpty ifTrue:
[^ (PopUpMenu labels: ' OK ')
startUpWithCaption: 'There are no
instance variables.'].
labelStream skip: -1 "cut last CR".
index _ (PopUpMenu labels: labelStream contents lines: lines) startUp.
index = 0 ifTrue: [^ self].
aBlock value: (allVars at: index)!
forceNewFrom: anArray
"Create a new instance of the class and fill
its instance variables up with the array."
| object max |
object _ self new.
max _ self instSize.
anArray doWithIndex: [:each :index |
index > max ifFalse:
[object instVarAt: index put: each]].
^ object!
instVarNames
"Answer an Array of the receiver's instance variable names."
instanceVariables == nil
ifTrue: [^#()]
ifFalse: [^instanceVariables]!
removeInstVarName: aString
"Remove the argument, aString, as one of the receiver's instance
variables. Create an error notification if the argument is not found."
"weird name is so that it will come lexically before #compile, so that a clean build can make it through. 7/7/96 sw"
^ true!
checkForPerform: selector in: aController
"If this newly accepted method contains a perform:, remind the user to put in fake code with the selectors the perform would use. So senders of those selectors will find this code. tck 1991
1/22/96 sw: MacPal -> Utilities
1/24/96 sw: temporarily, at least, bypassed this guy"
| meth hasPerform |
self flag: #noteToDan.
"Ted put this into our image back in 1991, in an effort to force uses who insist on using #perform to put some fake source into their code so that all the selectors likely to be invoked by the perform will be retrieved when one queries senders. While agreeing this a promising approach, in practice I found it quite a nuisance and also the found the implementation somewhat flawed, so for the moment (more for my personal convenience than as any kind of formal statement) I've commented it out... 2/5/96 sw"
"My approach to this would be to disallow all uses of perform:, and replace them with
obj perform: selector from: #(list of selectors).
This provides in-code documenstation, leverage for senders and inplementersOf. It gives type inference the clue it needs as well, not to mention the possibility of run-time checks on perform: 4/22/96 di"
"Intercept this message in order to remember system changes.
5/15/96 sw: modified so that if the class does not wish its methods logged in the changes file, then they also won't be accumulated in the current change set.
7/12/96 sw: use wantsChangeSetLogging to determine whether to put in change set"
"Answer a string that describes what kind of subclass the receiver is, i.e.,
variable, variable byte, variable word, or not variable."
self isVariable
ifTrue: [self isBits
ifTrue: [self isBytes
ifTrue: [^' variableByteSubclass: ']
ifFalse: [^' variableWordSubclass: ']]
ifFalse: [^' variableSubclass: ']]
ifFalse: [^' subclass: ']!
methods
"Answer a ClassCategoryReader for accessing the messages in the method dictionary category, 'as yet unclassified', of the receiver. Used for filing in fileouts made with Smalltalk/V"
^ClassCategoryReader class: self category: 'imported from V' asSymbol!
methodsFor: aString
"Answer a ClassCategoryReader for accessing the messages in the method
"Remove oldObject as one of the receiver's elements. If several of the
elements are equal to oldObject, only one is removed. If no element is
equal to oldObject, answer the result of evaluating anExceptionBlock.
Otherwise, answer the argument, oldObject. SequenceableCollections
cannot respond to this message."
self subclassResponsibility!
removeAll: aCollection
"Remove each element of aCollection from the receiver. If successful for
each, answer aCollection. Otherwise create an error notification."
aCollection do: [:each | self remove: each].
^aCollection!
removeAllFoundIn: aCollection
"Remove each element of aCollection which is present in the receiver from the receiver"
aCollection do: [:each | self remove: each ifAbsent: []].
^aCollection!
removeAllSuchThat: aBlock
"Apply the condition to each element and remove it if the condition is true. Use a copy to enumerate collections whose order changes when an element is removed (Set)."
| copy newCollection |
newCollection _ self species new.
copy _ self copy.
copy do: [:element |
(aBlock value: element) ifTrue: [
self remove: element.
newCollection add: element]].
^ newCollection! !
!Collection methodsFor: 'enumerating'!
associationsDo: aBlock
"Evaluate aBlock for each of the receiver's elements (key/value
associations). If any non-association is within, the error is not caught now,
but later, when a key or value message is sent to it."
self do: aBlock!
collect: aBlock
"Evaluate aBlock with each of the receiver's elements as the argument.
Collect the resulting values into a collection like the receiver. Answer
classVariableNames: 'LightYellow RandomStream Magenta ComponentMax Cyan LightGray Depth16GreenShift PureBlue White PureYellow Depth16RedShift GrayToIndexMap Green ColorChart Depth32BlueShift LightGreen Depth16BlueShift Yellow PureCyan ColorNames HalfComponentMask DarkGray Blue Black VeryDarkGray Red BlueShift VeryLightGray LightMagenta GreenShift Depth32GreenShift Depth32RedShift RedShift PureMagenta IndexedColors ComponentMask PureGreen LightRed LightCyan HighLightBitmaps Gray LightOrange LightBrown PureRed LightBlue '
poolDictionaries: ''
category: 'Graphics-Display Objects'!
Color comment:
'This class represents abstract color, regardless of the depth of bitmap it will be shown in. At the very last moment a Color is converted to a pixelValue that depends on the depth of the actual Bitmap inside the Form it will be used with. The supported depths (in bits) are 1, 2, 4, 8, 16, and 32. The number of actual colors at these depths are: 2, 4, 16, 256, 32768, and 16 million. (See comment in BitBlt.) To change the depth of the Display and set how many colors you can see, execute: (Display newDepth: 8). (See comment in DisplayMedium)
Color is represented as the amount of light in red, green, and blue. White is (1.0, 1.0, 1.0) and black is (0, 0, 0). Pure red is (1.0, 0, 0). These colors are "additive". Think of Color''s instance variables as:
r amount of red, a Float between 0.0 and 1.0.
g amount of green, a Float between 0.0 and 1.0.
b amount of blue, a Float between 0.0 and 1.0.
(But, in fact, the three are encoded as values from 0 to 1023 and combined in a single integer, rgb. The user does not need to know this.)
Many colors are named. You find a color by name by sending a message to class Color, for example (Color lightBlue). Also, (Color red: 0.2 green: 0.6 blue: 1.0) or (Color r: 0.2 g: 0.6 b: 1.0) creates a color. (see below)
A color is essentially immutable. Once you set red, green, and blue, you cannot change them. Instead, create a new Color and use it.
Applications such as contour maps and bar graphs will want to display one of a set of shades based on a number. Convert the range of this number to an integer from 1 to N. Then call (Color green lightShades: N) to get an Array of colors from white to green. Use the Array messages at:, atPin:, or atWrap: to pull out the correct color from the array. atPin: gives the first (or last) color if the index is out of range. atWrap: wraps around to the other end if the index is out of range.
Here are some fun things to run in when your screen has color:
Pen new mandala: 30 diameter: Display height-100.
Pen new web "Draw with the mouse, opt-click to end"
Display fillWhite. Pen new hilberts: 5.
Form toothpaste: 30 "Draw with mouse, opt-click to end"
You might also want to try the comment in
Form>class>examples>tinyText...
Messages:
mixed: proportion with: aColor Answer this color mixed with the given color additively. The proportion, a number between 0.0 and 1.0, determines what what fraction of the receiver to use in the mix.
+ add two colors
- subtract two colors
* multiply the values of r, g, b by a number or an Array of factors. ((Color named: #white) * 0.3) gives a darkish gray. (aColor * #(0 0 0.9)) gives a color with slightly less blue.
/ divide a color by a factor or an array of three factors.
errorForDepth: d How close the nearest color at this depth is to this abstract color. Sum of the squares of the RGB differences, square rooted and normalized to 1.0. Multiply by 100 to get percent.
hue Returns the hue of the color. On a wheel from 0 to 360 with pure red at 0 and again at 360.
saturation Returns the saturation of the color. 0.0 to 1.0
brightness Returns the brightness of the color. 0.0 to 1.0
name Look to see if this Color has a name.
display Show a swatch of this color tracking the cursor.
lightShades: thisMany An array of thisMany colors from white to the receiver.
darkShades: thisMany An array of thisMany colors from black to the receiver. Array is of length num.
mix: color2 shades: thisMany An array of thisMany colors from the receiver to color2.
wheel: thisMany An array of thisMany colors around the color wheel starting and ending at the receiver.
pixelValueForDepth: d Returns the bits that appear be in a Bitmap of this depth for this color. Represents the nearest available color at this depth. Normal users do not need to know which pixelValue is used for which color.
Messages to Class Color.
red: r green: g blue: b Return a color with the given r, g, and b components.
r: g: b: Same as above, for fast typing.
hue: h saturation: s brightness: b Create a color with the given hue, saturation, and brightness.
pink
blue
red ... Many colors have messages that return an instance of Color.
canUnderstand: #brown Returns true if #brown is a defined color.
names An OrderedCollection of the names of the colors.
named: #notAllThatGray put: aColor Add a new color to the list and create an access message and a class variable for it.
fromUser Shows the palette of colors available at this display depth. Click anywhere to return the color you clicked on.
hotColdShades: thisMany An array of thisMany colors showing temperature from blue to red to white hot.
stdColorsForDepth: d An Array of colors available at this depth. For 16 bit and 32 bits, returns a ColorGenerator. It responds to at: with a Color for that index, simulating a very big Array.
colorFromPixelValue: value depth: d Returns a Color whose bit pattern (inside a Bitmap) at this depth is the number specified. Normal users do not need to use this.
(See also comments in these classes: Form, Bitmap, BitBlt, Pattern, MaskedForm.)'!
!Color methodsFor: 'examples'!
display
"Show a swatch of this color tracking the cursor until the next mouseClick. 6/14/96 tk"
"Color red display"
| f c |
f _ Form extent: 40@20 depth: Display depth.
c _ Bitmap with: (self pixelWordForDepth: Display depth).
"Shows a palette of hues, varying the saturation and brightness for each one."
"Color new hsvExample. Modified 6/14/96 tk"
| d v x y c rect |
d _ Display depth.
c _ Color new. "modified in loop below"
rect _ 0@0 extent: 5@5. "modified in loop below"
0 to: 179 by: 15 do: [:h |
0 to: 10 do: [:s |
0 to: 10 do: [:v |
c setHue: h saturation: s asFloat / 10.0 brightness: v asFloat / 10.0.
rect left: (h*4) + (s*5); width: 5.
rect top: (v*5); height: 5.
Display fill: rect fillColor: (c bitPatternForDepth: d).
c setHue: h + 180 saturation: s asFloat / 10.0 brightness: v asFloat / 10.0.
rect top: (v*5) + 80; height: 5.
Display fill: rect fillColor: (c bitPatternForDepth: d).
].
].
].
!
showHuesAtSaturation: s brightness: v
"Shows a palette of hues at the given (saturation, brightness) point."
"Color new showHuesAtSaturation: 0.9 brightness: 0.9"
| rect c |
rect _ 0@0 extent: 5@5. "modified in loop below"
0 to: 179 by: 10 do: [:h |
c _ Color hue: h saturation: s brightness: v.
rect left: 5 + (h*4); width: 35.
rect top: 5; height: 35.
Display fill: rect fillColor: c.
c setHue: h + 180 saturation: s brightness: v.
rect top: 45; height: 35.
Display fill: rect fillColor: c.
].
!
showHuesInteractively
"Shows a palette of hues at (saturation, brightness) point determined by the mouse position. Click mouse button to exit and return the selected saturation and brightness."
"Color new showHuesInteractively"
| baseP p s v |
baseP _ Sensor cursorPoint.
[Sensor anyButtonPressed] whileFalse: [
p _ Sensor cursorPoint.
s _ ((p x - baseP x) + 80) asFloat / 100.0.
v _ ((p y - baseP y) + 80) asFloat / 100.0.
self showHuesAtSaturation: s brightness: v.
].
^ (s min: 1.0) @ (v min: 1.0)!
showPalette
"Show the 12x12x12 palette used in fromUser.
Color new showPalette"
| c rect |
"RGB display gives 12x12x12 cube to choose from"
c _ Color new. "modified in loop below"
rect _ 0@0 extent: 5@5. "modified in loop below"
0 to: 11 do: [:r |
0 to: 11 do: [:g |
0 to: 11 do: [:b |
c setRed: r green: g blue: b range: 11.
rect left: (r*60) + (b*5); width: 5.
rect top: (g*5); height: 5.
Display fill: rect fillColor: c.
].
].
].
!
test
IndexedColors do: [ :c |
].!
test: depth
"Color new test: 8"
| i c |
1 to: (1 << depth) do: [ :i |
c _ IndexedColors at: i.
(Color colorFromPixelValue: (c pixelValueForDepth: depth) value depth: depth) = c
ifFalse: [ self error: 'bad conversion' ].
].! !
!Color methodsFor: 'access'!
blue
"Answer my blue component, a float in the range [0.0..1.0].
Don't confuse this with the class message (Color blue) that returns the color pure blue. 6/13/96 tk"
^ self privateBlue asFloat / ComponentMax!
brightness
"Return the brightness of this paint color, a float in the range [0.0..1.0]."
^ ((self privateRed max:
self privateGreen) max:
self privateBlue) asFloat / ComponentMax!
green
"Answer my green component, a float in the range [0.0..1.0].
Don't confuse this with the class message (Color green) that returns the color pure green. 6/13/96 tk"
^ self privateGreen asFloat / ComponentMax!
hue
"Return the hue of this color, an angle in the range [0.0..360.0]."
"Answer my red component, a float in the range [0.0..1.0].
Don't confuse this with the class message (Color red) that returns the color pure red. 6/13/96 tk"
^ self privateRed asFloat / ComponentMax!
saturation
"Return the saturation of this color, a value between 0.0 and 1.0."
| r g b max min |
r _ self privateRed.
g _ self privateGreen.
b _ self privateBlue.
max _ ((r max: g) max: b).
min _ ((r min: g) min: b).
max = 0
ifTrue: [ ^ 0.0 ]
ifFalse: [ ^ (max - min) asFloat / max asFloat ].
! !
!Color methodsFor: 'groups of shades'!
darkShades: thisMany
"An array of thisMany colors from black to the receiver. Array is of length num. Very useful for displaying color based on a variable in your program. 6/18/96 tk"
^ self class black mix: self shades: thisMany
"| a r | a _ (Color red darkShades: 10).
r _ 0@0 extent: 30@30.
a do: [:each |
r moveBy: 30@0.
Display fill: r fillColor: each].
"!
lightShades: thisMany
"An array of thisMany colors from white to self. Very useful for displaying color based on a variable in your program. 6/18/96 tk"
^ self class white mix: self shades: thisMany
"| a r | a _ (Color red lightShades: 10).
r _ 0@0 extent: 30@30.
a do: [:each |
r moveBy: 30@0.
Display fill: r fillColor: each].
"!
mix: color2 shades: thisMany
"Return an array of thisMany colors from self to color2. Very useful for displaying color based on a variable in your program. 6/18/96 tk"
| redInc greenInc blueInc rr gg bb c out |
thisMany = 1 ifTrue: [^ Array with: color2].
redInc _ color2 red - self red / (thisMany-1).
greenInc _ color2 green - self green / (thisMany-1).
blueInc _ color2 blue - self blue / (thisMany-1).
rr _ self red. gg _ self green. bb _ self blue.
out _ (1 to: thisMany) collect: [:num |
c _ Color r: rr g: gg b: bb.
rr _ rr + redInc.
gg _ gg + greenInc.
bb _ bb + blueInc.
c].
out at: out size put: color2. "hide roundoff errors"
^ out
"| a r | a _ (Color red mix: Color green shades: 10).
r _ 0@0 extent: 30@30.
a do: [:each |
r moveBy: 30@0.
Display fill: r fillColor: each].
"!
wheel: thisMany
"An array of thisMany colors around the color wheel starting at self and ending all the way around the hue space just before self. Array is of length thisMany. Very useful for displaying color based on a variable in your program. 6/18/96 tk"
| sat bri hue step c |
thisMany = 1 ifTrue: [^ Array with: self].
sat _ self saturation.
bri _ self brightness.
hue _ self hue.
step _ 360.0/thisMany.
^ (1 to: thisMany) collect: [:num |
c _ Color hue: hue saturation: sat brightness: bri.
hue _ hue + step. "it does mod 360"
c].
"| a r | a _ (Color blue wheel: 20).
r _ 0@0 extent: 30@30.
a do: [:each |
r moveBy: 30@0.
Display fill: r fillColor: each].
"! !
!Color methodsFor: 'equality'!
= aColor
^ aColor isColor and: [aColor rgb = rgb]!
hash
^ rgb!
isColor
^ true! !
!Color methodsFor: 'transformations'!
* aFactor
"Answer this color with its RGB multiplied by aFactor or a vector of factors. Try:
((Color white) * 0.3) display a darkish gray.
((Color blue) * #(0 0 0.9)) display slightly less than blue. 6/18/96 tk"
"Return a lighter shade of the same color. 1/6th towards white. 6/18/96 tk Should this be an absolute step, instead of relative?"
^ self mixed: 5/6 with: Color white!
mixed: proportion with: aColor
"Answer this color mixed with the given color. The proportion,
a number between 0.0 and 1.0, determines what what fraction
of the receiver to use in the mix. For example, 0.9 would yield
a color close to the receiver."
"Details: This method uses RGB interpolation; HSV interpolation
can lead to surprises."
| frac1 frac2 |
frac1 _ proportion asFloat min: 1.0 max: 0.0.
frac2 _ 1.0 - frac1.
^ Color
red: (self red * frac1) + (aColor red * frac2)
green: (self green * frac1) + (aColor green * frac2)
blue: (self blue * frac1) + (aColor blue * frac2)
! !
!Color methodsFor: 'conversions'!
bitPatternForDepth: depth
"The raw call on BitBlt needs a Bitmap to represent this color. Return the color at the destination Form depth as a Bitmap. Pattern returns a longer Bitmap. 6/14/96 tk
For the bits that are in a single pixel, use pixelValueAtDepth:.
For a 32-bit integer of (32/depth) pixels, use pixelWordAtDepth:"
"How close the nearest color at this depth is to this abstract color. Sum of the squares of the RGB differences, square rooted and normalized to 1.0. Multiply by 100 to get percent. 6/19/96 tk"
| p col r g b rdiff gdiff bdiff diff |
p _ self pixelValueForDepth: d.
col _ Color colorFromPixelValue: p depth: d.
r _ self privateRed. g _ self privateGreen. b _ self privateBlue.
"Return the index corresponding to this color in a 512-entry color transformation map. RGB forms collapse to 3 bits per color when indexing into such a colorMap."
"The above gives the same result as this explanation:
| d word |
d _ depth.
word _ val.
[d >= 32] whileFalse: [
word _ word bitOr: (word bitShift: d).
d _ d+d].
^ Bitmap with: word
"!
pixelValue: val toPixelWordDepth: depth
"convert to a 32 bit quantity. Covers 32//depth pixels. 6/14/96 tk"
| d word |
d _ depth.
word _ val.
[d >= 32] whileFalse: [
word _ word bitOr: (word bitShift: d).
d _ d+d].
^ word
!
pixelValueForDepth: d
"Answer bits that appear in ONE pixel of this color in a Bitmap of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Returns an integer. Contrast with pixelWordForDepth: and bitPatternForDepth:. Inverse is the class message colorFromPixelValue:depth:"
"Details: For depths of 8 or less, the result is a colorMap index (zero order). For depths of 16 and 32, it is a direct color with 5 or 8 bits per color component. 6/1/96 jm, 6/14/96 tk"
d < 8 ifTrue: [ ^ self closestPixelValueDepth: d ].
self error: 'unknown pixel depth: ', d printString
!
pixelWordForDepth: depth
"Answer bits that appear in a 32-bit word of a Bitmap of the given depth. This may represent between 32 and 1 pixels, depending on the depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Returns an integer."
| word d |
word _ self pixelValueForDepth: depth.
d _ depth.
[d >= 32] whileFalse: [
word _ word bitOr: (word bitShift: d).
d _ d+d].
^ word! !
!Color methodsFor: 'printing'!
printOn: aStream
aStream
nextPutAll: 'Color(';
nextPutAll: (self red roundTo: 0.001) printString;
nextPutAll: ', ';
nextPutAll: (self green roundTo: 0.001) printString;
nextPutAll: ', ';
nextPutAll: (self blue roundTo: 0.001) printString;
nextPutAll: ')'.
!
storeOn: aStream
aStream
nextPutAll: '(Color r:';
nextPutAll: (self red roundTo: 0.001) printString;
nextPutAll: ' g: ';
nextPutAll: (self green roundTo: 0.001) printString;
nextPutAll: ' b: ';
nextPutAll: (self blue roundTo: 0.001) printString;
nextPutAll: ')'.
! !
!Color methodsFor: 'private'!
closestColor1
"Return the nearest approximation to this color for a monochrome Form.
Should this be based on r+g+b? Should it be L. lightness, in L*a*b* space? 6/14/96 tk"
self halt. "old"
self brightness > 0.5
ifTrue: [ ^ 0 ]
ifFalse: [ ^ 1 ].!
closestColor2
"Return the nearest approximation to this color for a 2-bit deep Form."
| b |
self halt. "old"
self = PureYellow ifTrue: [ ^ 16rFFFFFFFF ].
b _ self brightness.
b >= 0.75 ifTrue: [ ^ 0 ].
b <= 0.25 ifTrue: [ ^ 16r55555555 ].
^ 16rAAAAAAAA!
closestColor4
"Return the nearest approximation to this color for a 4-bit deep Form."
| bIndex |
self halt. "old"
self = PureYellow ifTrue: [ ^ 16r33333333 ].
self = PureRed ifTrue: [ ^ 16r44444444 ].
self = PureGreen ifTrue: [ ^ 16r55555555 ].
self = PureBlue ifTrue: [ ^ 16r66666666 ].
self = PureCyan ifTrue: [ ^ 16r77777777 ].
self = PureMagenta ifTrue: [ ^ 16r88888888 ].
bIndex _ (self brightness * 8.0) rounded. "bIndex in [0..8]"
^ #(
16r11111111 "black"
16r99999999 "7/8 gray"
16rAAAAAAAA "6/8 gray"
16rBBBBBBBB "5/8 gray"
16rCCCCCCCC "4/8 gray"
16rDDDDDDDD "3/8 gray"
16rEEEEEEEE "2/8 gray"
16rFFFFFFFF "1/8 gray"
16r00000000 "white"
) at: bIndex + 1
!
closestColor8
"Return the nearest approximation to this color for an 8-bit deep Form."
^ IndexedColors at: (self closestPixelValue8)+1!
closestColor8old
"Return the nearest approximation to this color for an 8-bit deep Form."
| bIndex p n |
self isGray ifTrue: [
"select nearest gray"
p _ GrayToIndexMap at: (self privateBlue >> 2) + 1.
"Return the nearest approximation to this color for this depth of Form. Depth can be 1, 2, 4, or 8. This method is for when we go to L*a*b* color space. For now use the faster version. 6/14/96 tk"
| least r g b col rdiff gdiff bdiff diff leastIndex |
depth > 8 ifTrue: [^ self error: 'depth must be 1, 2, 4, or 8'].
least _ ComponentMask*ComponentMask*3. "start with max"
r _ self privateRed. g _ self privateGreen. b _ self privateBlue.
"Return the nearest approximation to this color for a monochrome Form.
Should this be based on r+g+b? Should it be L. lightness, in L*a*b* space? 6/14/96 tk"
self brightness > 0.5
ifTrue: [ ^ 0 ]
ifFalse: [ ^ 1 ].!
closestPixelValue8
"Return the index in the standard 8-bit colormap for the nearest match to this color. Find the closest color in our 6x6x6 color cube. See if any of the grays are closer to the real color. 6/14/96 tk"
| r g b rr gg bb diff gray val diffg diffc pvtGray rd gd bd |
rgb = 0 ifTrue: [^ 1]. "Special case for black, very common"
rgb = 16r3FFFFFFF ifTrue: [^ 0].
"Special case for white, very common"
"Find the closest color in our 6x6x6 color cube. Integers in [0..5]"
r _ (((self privateRed * 5) + HalfComponentMask) // ComponentMask).
g _ (((self privateGreen * 5) + HalfComponentMask) // ComponentMask).
b _ (((self privateBlue * 5) + HalfComponentMask) // ComponentMask).
"Return the nearest approximation to this color for this depth of Form. Depth can be 1, 2, 4, or 8. This method is for when we go to L*a*b* color space. For now use the faster version. 6/14/96 tk"
| least r g b col rdiff gdiff bdiff diff leastIndex |
depth > 256 ifTrue: [^ self error: 'depth must be 1, 2, 4, or 8'].
least _ ComponentMask*ComponentMask*3 + 100. "start with max"
r _ self privateRed. g _ self privateGreen. b _ self privateBlue.
"Initialize this color's r, g, and b components to the given values in [0.0..1.0]. Range is [0..r], a weird numbering system with size r+epsilon, min 0, max r. 6/14/96 tk"
| range |
range _ zeroToThis.
rgb == nil ifFalse: [^ self error: 'Can''t write into a Color. Make a new one'].
"Return the colorMap for the depth. Use a ColorGenerator to simulate a very big Array for 16 and 32. 6/22/96 tk"
d < 16 ifTrue: [^ IndexedColors copyFrom: 1 to: (1 bitShift: d)].
^ ColorGenerator new depth: d!
black
^Black!
blue
^Blue!
cyan
^Cyan!
darkGray
^DarkGray!
gray
^Gray!
green
^Green!
lightBlue
^LightBlue!
lightBrown
^LightBrown!
lightCyan
^LightCyan!
lightGray
^LightGray!
lightGreen
^LightGreen!
lightMagenta
^LightMagenta!
lightOrange
^LightOrange!
lightRed
^LightRed!
lightYellow
^LightYellow!
magenta
^Magenta!
named: newName put: aColor
"Add a new color to the list and create an access message and a class variable for it. The name should start with a lowercase letter. (The class variable will start with an uppercase letter.) (Color names) gives a list of the colors. 6/13/96 tk"
| str cap sym accessor csym |
(aColor isKindOf: self) ifFalse: [^ self error: 'not a Color'].
str _ newName asString.
sym _ str asSymbol.
cap _ str copy.
cap at: 1 put: (cap at: 1) asUppercase.
csym _ cap asSymbol.
(self class canUnderstand: sym) ifFalse: [
"define access message"
accessor _ str, (String with: Character cr with: Character tab), '^', cap.
self class compile: accessor
classified: 'colors'].
(self classPool includesKey: csym) ifFalse: [
self addClassVarName: cap].
(ColorNames includes: sym) ifFalse: [
ColorNames add: sym].
^ self classPool at: csym put: aColor!
names
"Return a list of names of colors. An OrederdCollection of symbols. 6/14/96 tk
Color perform: (Color names at: 1) "
^ ColorNames!
red
^Red!
veryDarkGray
^VeryDarkGray!
veryLightGray
^VeryLightGray!
white
^White!
yellow
^Yellow! !
!Color class methodsFor: 'instance creation'!
colorChartForDepth: depth extent: chartExtent
"Displays a color palette using abstract colors. fromUser can then save it. Different for each depth. 6/26/96 tk
Modified to produce a form of variable size instead of being
"Create a color with the given hue, saturation, and brightness. Hue is given as the angle in degrees of the color on the color circle where red is zero degrees. Saturation and brightness are numbers in [0.0..1.0] where larger values are more saturated or brighter colors. For example:
"Return a color with the given r, g, and b components."
^ self basicNew setRed: r green: g blue: b!
r: r g: g b: b alpha: alpha
^ (self r: r g: g b: b) alpha: alpha!
random
^ self basicNew
setHue: (360.0 * RandomStream next)
saturation: (0.3 + (RandomStream next * 0.7))
brightness: (0.4 + (RandomStream next * 0.6))!
red: r green: g blue: b
"Return a color with the given r, g, and b components."
^ self basicNew setRed: r green: g blue: b!
red: r green: g blue: b range: range
"Return a color with the given r, g, and b components specified as integers in the range [0..r]. This avoids the floating point arithmetic in the red:green:blue: message and is thus a bit faster for certain applications (such as computing a sequence of colors for a palette)."
^ self basicNew setRed: r green: g blue: b range: range! !
!Color class methodsFor: 'misc'!
makeColorMap: colorArray depth: bitsPerPixel
"colorArray is now an Array of (256) Colors that the picture wants to use. We have a fixed palette of 256 Colors. Convert each to the closest of our colors and return a mapping vector. Note we use zero-order (0-255) colors here. 6/24/96 tk"
'This class behaves like an array holding a very large number of colors. It responds to at: by looking up the Nth Color, making an instance of it and returning it. For the colorMap of 16-bit and 32-bit colors as given by Color allColorsForDepth: d.
at: index Returns a Color by calling (Color colorForPixelValue: index depth: d) which unpacks the bits in the pixelValue.
'I represent a method suitable for interpretation by the virtual machine. My instances have pointer fields, including a header and some literals, followed by non-pointer fields comprising the byte encoded instructions for the method. The header encodes the number of arguments, the number of literals, and the amount of temporary space needed (for context allocation).
An extra three bytes are added after the executable code. These contain an external file address to the source code for the method.'!
!CompiledMethod methodsFor: 'initialize-release'!
needsFrameSize: newFrameSize
"Set the largeFrameBit to accomodate the newFrameSize.
NOTE: I think the >= below is overly cautious.
Recompile the system with just > some day - DI 2/26/96"
| largeFrameBit header |
largeFrameBit _ 16r20000.
(self numTemps + newFrameSize) >= LargeFrame
ifTrue: [^self error: 'Cannot compile--stack including temps is too deep'].
instanceVariableNames: 'sourceStream requestor class context '
classVariableNames: ''
poolDictionaries: ''
category: 'System-Compiler'!
Compiler comment:
'The compiler accepts Smalltalk source code and compiles it with respect to a given class. The user of the compiler supplies a context so that temporary variables are accessible during compilation. If there is an error, a requestor (usually a kind of StringHolderController) is sent the message notify:at:in: so that the error message can be displayed. If there is no error, then the result of compilation is a MethodNode, which is the root of a parse tree whose nodes are kinds of ParseNodes. The parse tree can be sent messages to (1) generate code for a CompiledMethod (this is done for compiling methods or evaluating expressions); (2) pretty-print the code (for formatting); or (3) produce a map from object code back to source code (used by debugger program-counter selection). See also Parser, Encoder, ParseNode.'!
!Compiler methodsFor: 'error handling'!
interactive
"Answer whether there is a requestor of the compiler who should be
'To the instruction parsing ability of InstructionStream I add the actual semantics for execution. The execution state is stored in the indexable fields of my subclasses. This includes temporary variables and a stack of values used in evaluating expressions. The actual semantics of execution can be found in my category "system simulation" and "instruction decode". These methods exactly parallel the operation of the Smalltalk machine itself.
The simulator is a group of my methods that do what the Smalltalk interpreter does: execute Smalltalk bytecodes. By adding code to the simulator, you may take statistics on the running of Smalltalk methods. For example,
'I am a BrowserCodeController but the doIt command is redefined. The result of the evaluation is stored as the proceed value for the interrupted (selected) method.'!
'I am a kind of LockedListController for the upper subView of a DebuggerView that creates a yellow button menu so that messages can be sent to the list selection (a message) to:
fullStack change from displaying the minimal stack to a full one
proceed proceed evaluation from the interrupted expression
restart restart evaluation from the beginning of the method
send execute the next message that a step would invoke
spawn create a browser for the code of the model''s selected message
step execute the next expression in the selected method
where toggle the flag that indicates whether to show the pc selection'!
'I am a ListView whose items are the methods (interrupted message-sends) of the Debugger that I view. ContextStackListController is my default controller.'!
!ContextStackListView methodsFor: 'model access'!
model: aDebugger
super model: aDebugger.
self list: model contextStackList! !
!ContextStackListView methodsFor: 'updating'!
update: aSymbol
aSymbol == #contextStackIndex
ifTrue: [self moveSelectionBox: model contextStackIndex].
'I represent a query path into the internal representation of a ContextPart. Typically this is a context at a point in the query path of a Debugger. As a StringHolder, the string I represent is the value of the currently selected variable of the observed temporary variable of the context.'!
'A Controller coordinates a View, its model, and user actions. It provides scheduling (control) behavior to determine when the user wants to communicate with the model or view.'!
!Controller methodsFor: 'initialize-release'!
initialize
"Initialize the state of the receiver. Subclasses should include 'super
initialize' when redefining this message to insure proper initialization."
sensor _ InputSensor default!
release
"Breaks the cycle between the receiver and its view. It is usually not
necessary to send release provided the receiver's view has been properly
released independently."
model _ nil.
view ~~ nil
ifTrue:
[view controller: nil.
view _ nil]! !
!Controller methodsFor: 'model access'!
model
"Answer the receiver's model which is the same as the model of the
receiver's view."
^model!
model: aModel
"Controller|model: and Controller|view: are sent by View|controller: in
order to coordinate the links between the model, view, and controller. In
ordinary usage, the receiver is created and passed as the parameter to
View|controller: so that the receiver's model and view links can be set
up by the view."
model _ aModel! !
!Controller methodsFor: 'view access'!
inspectView
view notNil ifTrue: [^ view inspect]!
view
"Answer the receiver's view."
^view!
view: aView
"Controller|view: and Controller|model: are sent by View|controller: in
order to coordinate the links between the model, view, and controller. In
ordinary usage, the receiver is created and passed as the parameter to
View|controller: and the receiver's model and view links are set up
automatically by the view."
view _ aView! !
!Controller methodsFor: 'sensor access'!
sensor
"Answer the receiver's sensor. Subclasses may use other objects that are
not instances of Sensor or its subclasses if more general kinds of
input/output functions are required."
^sensor!
sensor: aSensor
"Set the receiver's sensor to aSensor."
sensor _ aSensor! !
!Controller methodsFor: 'basic control sequence'!
controlInitialize
"Sent by Controller|startUp as part of the standard control sequence, it
provides a place in the standard control sequence for initializing the
receiver (taking into account the current state of its model and view). It
should be redefined in subclasses to perform some specific action."
^self!
controlLoop
"Sent by Controller|startUp as part of the standard control sequence.
Controller|controlLoop sends the message Controller|isControlActive to test
for loop termination. As long as true is returned, the loop continues.
When false is returned, the loop ends. Each time through the loop, the
'I represent the top level control over scheduling which controller of a view on the screen the user is actively using. ScheduledControllers is the global reference to an instance of me, the one attached to the Project currently being used.'!
!ControlManager methodsFor: 'initialize-release'!
initialize
"Initialize the receiver to refer to only the background controller."
| screenView |
screenController _ ScreenController new.
screenView _ FormView new.
screenView model: (InfiniteForm with: Color gray) controller: screenController.
"Present a menu of window titles, and activate the one that gets chosen
1/18/96 sw: Created this version with an argument for more general use, and also, as per Dan's request, modified so that windows whose topleft corners are beyond the lower-right screen corner get picked up by the window-rescue piece.
"Clear the screen to gray and then redisplay all the scheduled views. Try to be a bit intelligent about the view that wants control and not display it twice if possible..
1/24/96 sw: uncache bits of top view"
scheduledControllers first view uncacheBits. "assure refresh"
"Answer the instance of me that is the shape of the bottom right corner
of a rectangle."
^CornerCursor!
crossHair
"Answer the instance of me that is the shape of a cross."
^CrossHairCursor!
down
"Answer the instance of me that is the shape of an arrow facing
downward."
^DownCursor!
execute
"Answer the instance of me that is the shape of an arrow slanted left
with a star next to it."
^XeqCursor!
marker
"Answer the instance of me that is the shape of a small ball."
^MarkerCursor!
menu
"Answer the instance of me that is the shape of a menu."
^MenuCursor!
move
"Answer the instance of me that is the shape of a cross inside a square."
^MoveCursor!
normal
"Answer the instance of me that is the shape of an arrow slanted left."
^NormalCursor!
origin
"Answer the instance of me that is the shape of the top left corner of a
rectangle."
^OriginCursor!
read
"Answer the instance of me that is the shape of eyeglasses."
^ReadCursor!
rightArrow
"Answer the instance of me that is the shape of an arrow pointing to the right."
^RightArrowCursor!
square
"Answer the instance of me that is the shape of a square."
^SquareCursor!
topLeft
"Cursor topLeft showWhile: [Sensor waitButton]"
^ (Cursor extent: 16@16
fromArray: #(
2r1111111111111111
2r1111111111111111
2r1100000000000000
2r1100000000000000
2r1100000000000000
2r1100000000000000
2r1100000000000000
2r1100000000000000
2r1100000000000000
2r1100000000000000
2r1100000000000000
2r1100000000000000
2r1100000000000000
2r1100000000000000
2r1100000000000000
2r1100000000000000)
offset: 0@0).
!
topRight
"Cursor topRight showWhile: [Sensor waitButton]"
^ (Cursor extent: 16@16
fromArray: #(
2r1111111111111111
2r1111111111111111
2r0000000000000011
2r0000000000000011
2r0000000000000011
2r0000000000000011
2r0000000000000011
2r0000000000000011
2r0000000000000011
2r0000000000000011
2r0000000000000011
2r0000000000000011
2r0000000000000011
2r0000000000000011
2r0000000000000011
2r0000000000000011)
offset: -16@0).
!
up
"Answer the instance of me that is the shape of an arrow facing upward."
^UpCursor!
wait
"Answer the instance of me that is the shape of an Hourglass (was in the
shape of three small balls)."
^WaitCursor!
write
"Answer the instance of me that is the shape of a pen writing."
^WriteCursor! !
Cursor initialize!
Path subclass: #Curve
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Graphics-Paths'!
Curve comment:
'I represent a conic section determined by three points p1,p2 and p3. I interpolate p1 and p3 and am tangent to line p1,p2 at p1 and line p3,p2 at p3.'!
'This is an interim save-to-disk facility. A DataStream can store one
or more objects in a persistent form.
To handle objects with sharing and cycles, you must use a
ReferenceStream instead of a DataStream. ReferenceStream is typically
faster and produces smaller files because it doesn''t repeatedly write
the same class Symbols.
Here is the way to use DataStream and ReferenceStream:
rr _ ReferenceStream fileNamed: ''test.obj''.
rr nextPut: <your object>.
rr close.
To get it back:
rr _ ReferenceStream fileNamed: ''test.obj''.
<your object> _ rr next.
rr close.
Each object to be stored has two opportunities to control what gets stored. The high level, more useful hook is objectToStoreOnDataStream [externalize]. The low level hook is storeDataOn:. The read-in counterparts to these messages are comeFullyUpOnReload [internalize] and (class) readDataFrom:size:. See these methods, the class DiskProxy, and the class IOWeakArray for more information about externalizing and internalizing.
Public messages:
(class) on:
(class) fileNamed:
(class) fileTypeCode
atEnd
beginInstance:size: (for use by storeDataOn: methods)
beginReference: (for use by readDataFrom:size: methods)
close
next
next:
nextPut:
nextPutAll:
reset
setType:
size
NOTE: A DataStream should be treated as a read-stream *or* as a
write-stream, *not* as a read/write-stream.
[TBD] We should be able to make this much faster via tight-loop
byte-string I/O. It looks like FileStream (and WriteStream)
nextPutAll: do a reasonable job *if* it doesn''t have to push the
writeLimit, in which case it iterates with nextPut:. It could in many
cases set the writeLimit and then use the fast case
(replaceFrom:to:with:startingAt:), or fill a buffer at at time via
the fast case working on a substring.
This approach would handle Strings, ByteArrays, and all other
variable-byte classes. If(nextPutAll: aCollection) in some cases
still reverts to (aCollection do: [:e | self nextPut: e]), then we''d
want to make Obj respond to do:. Then we could speed up inner
loop activities like nextPutInt32:.
[TBD] Every DataStream should begin with 4 signature bytes.
"on:" should emit or check the signature. But the current mechanism doesn''t always
know when the stream is started or ended.
[TBD] Cf. notes in DataStream>>beginInstance:size: and
Object>>readDataFrom:size:.
[TBD] We could save disk space & I/O time by using short, 1-byte size
fields whenever possible. E.g. almost all Symbols are shorter than
256 chars. We could do this either by (1) using different typeID codes
to indicate when a 1-byte length follows, a scheme which could still
read all the old files but would take more code, or (2) a
variable-length code for sizes.
-- 11/15/92 jhm'!
!DataStream methodsFor: 'as yet unclassified'!
atEnd
"Answer true if the stream is at the end."
^ byteStream atEnd!
beginInstance: aClass size: anInteger
"This is for use by storeDataOn: methods.
Cf. Object>>storeDataOn:."
"Addition of 1 seems to make extra work, since readInstance
has to compensate. Here for historical reasons dating back
to Kent Beck's original implementation in late 1988.
Also, we could save 5 bytes per instance by putting a Str255
on byteStream instead of putting a Symbol on self (which
entails a 1-byte type tag and a 4-byte length count).
Also, we could be more robust by emitting info indicating
whether aClass is fixed or variable, pointer or bytes, and
how many instance vars it has."
byteStream nextNumber: 4 put: anInteger + 1.
self nextPut: aClass name!
beginReference: anObject
"We╒re starting to read anObject. Remember it and its reference
position (if we care; ReferenceStream cares). Answer the
reference position."
^ 0!
errorWriteReference: anInteger
"PRIVATE -- Raise an error because this case of nextPut:╒s perform:
shouldn't be called. -- 11/15/92 jhm"
self error: 'This should never be called'!
flush
"Guarantee that any writes to me are actually recorded on disk. -- 11/17/92 jhm"
^ byteStream flush!
getCurrentReference
"PRIVATE -- Return the currentReference posn.
Overridden by ReferenceStream."
^ 0!
internalize: externalObject
"PRIVATE -- We just read externalObject. Give it a chance to
internalize. Return the internalized object."
^ externalObject comeFullyUpOnReload!
next: anInteger
"Answer an Array of the next anInteger objects in the stream."
| array |
array _ Array new: anInteger.
1 to: anInteger do: [:i |
array at: i put: self next].
^ array!
nextPutAll: aCollection
"Write each of the objects in aCollection to the
receiver stream. Answer aCollection."
^ aCollection do: [:each | self nextPut: each]!
noteCurrentReference: typeID
"PRIVATE -- If we support references for type typeID, remember
the current byteStream position so we can add the next object to
the ╘objects╒ dictionary, and return true. Else return false.
This method is here to be overridden by ReferenceStream"
^ false!
objectAt: anInteger
"PRIVATE -- Read & return the object at a given stream position.
11/16/92 jhm: Renamed local variable to not clash with an instance variable."
| savedPosn anObject refPosn |
savedPosn _ byteStream position.
refPosn _ self getCurrentReference.
byteStream position: anInteger.
anObject _ self next.
self setCurrentReference: refPosn.
byteStream position: savedPosn.
^ anObject!
outputReference: referencePosn
"PRIVATE -- Output a reference to the object at integer stream position
referencePosn. To output a weak reference to an object not yet written, supply
(self vacantRef) for referencePosn. -- 11/15/92 jhm"
byteStream nextPut: 10. "reference typeID"
byteStream nextNumber: 4 put: referencePosn!
readArray
"PRIVATE -- Read the contents of an Array.
We must do beginReference: here after instantiating the Array
but before reading its contents, in case the contents reference
the Array. beginReference: will be sent again when we return to
next, but that╒s ok as long as we save and restore the current
"Set my backing stream's file type code to my default file type code.
ASSUMES: My backing stream is a file stream. -- 11/13/92 jhm
For now, we do not control the Mac type and creator of the file 7/26/96 tk"
" self setType: self class fileTypeCode"!
setType: typeString
"Set my backing stream's file type code.
ASSUMES: My backing stream is a file stream. -- 11/13/92 jhm"
byteStream setType: typeString!
size
"Answer the stream's size."
^ byteStream size!
tryToPutReference: anObject typeID: typeID
"PRIVATE -- If we support references for type typeID, and if
anObject already appears in my output stream, then put a
reference to the place where anObject already appears. If we
support references for typeID but didn╒t already put anObject,
then associate the current stream position with anObject in
case one wants to nextPut: it again.
Return true after putting a reference; false if the object still
needs to be put.
For DataStream this is trivial. ReferenceStream overrides this."
^ false!
vacantRef
"Answer the magic 32-bit constant we use ***ON DISK*** as a stream ╥reference
position╙ to identify a reference that╒s not yet filled in. This must be a
value that won╒t be used as an ordinary reference. Cf. outputReference: and
readReference. -- 11/15/92 jhm
NOTE: We could use a different type ID for vacant-refs rather than writing
object-references with a magic value. (The type ID and value are
overwritten by ordinary object-references when weak refs are fullfilled.)
The current approach is convenient but wouldn't work if we changed object-
references to relative positions."
^ -1!
writeArray: anArray
"PRIVATE -- Write the contents of an Array."
byteStream nextNumber: 4 put: anArray size.
self nextPutAll: anArray.!
writeBitmap: aBitmap
"PRIVATE -- Write the contents of a Bitmap."
aBitmap writeOn: byteStream
"Note that this calls (byteStream nextPutAll: aBitmap) which knows enough to put 4-byte quantities on the stream!! Reader must know that size is in long words."!
"PRIVATE -- Write the contents of an UndefinedObject."!
writeString: aString
"PRIVATE -- Write the contents of a String."
aString size < 16384
ifTrue: [byteStream nextStringPut: aString]
ifFalse: [self writeByteArray: aString]. "takes more space"!
writeSymbol: aSymbol
"PRIVATE -- Write the contents of a Symbol."
self writeString: aSymbol!
writeTrue: aTrue
"PRIVATE -- Write the contents of a True."! !
!DataStream methodsFor: 'imported from V'!
checkForPaths: anObject
"After an object is fully internalized, it should have no PathFromHome in it. The only exceptiuon in Array, as pointed to by an IncomingObjects. 8/16/96 tk"
1 to: anObject class instSize do:
[:i | (anObject instVarAt: i) class == PathFromHome ifTrue: [
"After reading the externalObject, internalize it.
#readReference is a special case. Either:
(1) We actually have to read the object, recursively calling
next, which internalizes the object.
(2) We just read a reference to an object already read and
thus already interalized.
Either way, we must not re-internalize the object here."
selector == #readReference ifFalse:
[anObject _ self internalize: anObject.
self checkForPaths: anObject].
^ anObject!
nextPut: anObject
"Write anObject to the receiver stream. Answer anObject.
NOTE: If anObject is a reference type (one that we write cross-references to) but its externalized form (result of objectToStoreOnDataStream) isn╒t (e.g. CompiledMethod and ViewState), then we should remember its externalized form
but not add to ╘references╒. Putting that object again should just put its
external form again. That╒s more compact and avoids seeks when reading.
But we just do the simple thing here, allowing backward-references for
non-reference types like nil. So objectAt: has to compensate. Objects that
externalize nicely won╒t contain the likes of ViewStates, so this shouldn╒t
"PRIVATE -- For now, no classes may be written. HyperSqueak user unique classes have not state other than methods and should be reconstructed. Could read standard fileOut code here if necessary. 7/29/96 tk."
"do nothing"!
readInstance
"PRIVATE -- Read the contents of an arbitrary instance.
ASSUMES: readDataFrom:size: sends me beginReference: after it
instantiates the new object but before reading nested objects.
NOTE: We must restore the current reference position after
^ TypeMap at: anObject class ifAbsent: [9 "instance"]!
writeClass: aClass
"PRIVATE -- For now, no classes may be written. HyperSqueak user unique classes have not state other than methods and should be reconstructed. Could put standard fileOut code here is necessary. 7/29/96 tk."
Obj classPool at: #ErrorHolder put: aClass.
Transcript cr; show: 'The class ', aClass printString,' is trying to be written out. See Obj class variable ErrorHolder.'.
"do nothing"!
writeUser: anObject
"Write the contents of an arbitrary User instance (and its devoted class)."
" 7/29/96 tk"
"If anObject is an instance of a unique user class, will lie and say it has a generic class"
"TypeMap maps Smalltalk classes to type ID numbers which identify the data stream primitive formats. nextPut: writes these IDs to the data stream. NOTE: Changing these type ID numbers will invalidate all extant data stream files. Adding new ones is OK.
See nextPut:, next, typeIDFor:, & ReferenceStream>>isAReferenceType:"
"DataStream initialize"
| refTypes t |
refTypes _ OrderedCollection new.
t _ TypeMap _ Dictionary new: 30. "sparse for fast hashing"
t at: UndefinedObject put: 1. refTypes add: 0.
t at: True put: 2. refTypes add: 0.
t at: False put: 3. refTypes add: 0.
t at: SmallInteger put: 4. refTypes add: 0.
t at: String put: 5. refTypes add: 1.
t at: Symbol put: 6. refTypes add: 1.
t at: ByteArray put: 7. refTypes add: 1.
"Does anything use this?"
t at: Array put: 8. refTypes add: 1.
"(type ID 9 is for arbitrary instances, cf. typeIDFor:)"
refTypes add: 1.
"(type ID 10 is for references, cf. ReferenceStream>>tryToPutReference:)"
refTypes add: 0.
t at: Bitmap put: 11. refTypes add: 1.
t at: Metaclass put: 12. refTypes add: 0.
"Type ID 13 is used for HyperSqueak User classes that must be reconstructed."
refTypes add: 1.
t at: Float put: 14. refTypes add: 1.
"t at: put: 15. refTypes add: 0."
ReferenceStream refTypes: refTypes. "save it"!
newFileNamed: aString
"Here is the way to use DataStream and ReferenceStream:
rr _ ReferenceStream fileNamed: 'test.obj'.
rr nextPut: <your object>.
rr close.
"
^ self on: ((FileStream newFileNamed: aString) binary)!
on: aStream
"Open a new DataStream onto a low-level I/O stream.
'I represent a date. My printing format consists of an array of six elements.
The first three elements contain the numbers 1, 2, 3, in any order. 1 indicates that the day appears in this position, 2 indicates that the month appears in this position, and 3 indicates that the year appears in this position.
The fourth element is the ascii value of the character separator or the character itself.
The fifth element is the month format, where 1 indicates print as a number, 2 indicates print the first three characters, and 3 indicates print the entire name.
The six element is the year format, where 1 indicates print as a number, and 2 indicates print the number modulo 100.
Examples:
#(1 2 3 32 2 1) prints as 12 Dec 1981
#(2 1 3 $/ 1 2) prints as 12/12/81'!
!Date methodsFor: 'accessing'!
day
"Answer the day of the year represented by the receiver."
^day!
leap
"Answer whether the receiver's year is a leap year."
^Date leapYear: year!
monthIndex
"Answer the index of the month in which the receiver falls."
| leap firstDay |
leap _ self leap.
12 to: 1 by: -1 do:
[ :monthIndex |
firstDay _ (FirstDayOfMonth at: monthIndex)
+ (monthIndex > 2 ifTrue: [leap] ifFalse: [0]).
firstDay<= day
ifTrue: [^monthIndex]].
self error: 'illegal month'!
monthName
"Answer the name of the month in which the receiver falls."
^MonthNames at: self monthIndex!
weekday
"Answer the name of the day of the week on which the receiver falls."
^WeekDayNames at: self weekdayIndex!
year
"Answer the year in which the receiver falls."
^year! !
!Date methodsFor: 'arithmetic'!
addDays: dayCount
"Answer a Date that is dayCount days after the receiver."
^Date newDay: day + dayCount
year: year!
subtractDate: aDate
"Answer the number of days between the receiver and aDate."
year = aDate year
ifTrue: [^day - aDate day]
ifFalse: [^year - 1 // 4 - (aDate year // 4) + day
"Answer the receiver rendered in standard fmt mm/dd/yy. 1/17/96 sw. 2/1/96 sw Fixed to show day of month, not day. Note that the name here is slightly misleading -- the month and day numbers don't show leading zeros, so that for example feb 1 1996 is 2/1/96"
"Date today mmddyy"
^ self printFormat: #(2 1 3 $/ 1 99)!
printFormat: formatArray
"Answer a String describing the receiver using the format denoted by the
argument, formatArray."
| aStream |
aStream _ WriteStream on: (String new: 16).
self printOn: aStream format: formatArray.
^aStream contents!
printOn: aStream
self printOn: aStream format: #(1 2 3 $ 3 1 )!
printOn: aStream format: formatArray
"Print a description of the receiver on aStream using the format denoted
by the argument, formatArray:
#(item item item sep monthfmt yearfmt twoDigits)
items: 1=day 2=month 3=year will appear in the order given,
separated by sep which is eaither an ascii code or character.
monthFmt: 1=09 2=Sep 3=September
yearFmt: 1=1996 2=96
digits: (missing or)1=9 2=09.
See the examples in printOn: and mmddyy"
| monthIndex element monthFormat twoDigits monthDay |
'I represent the machine state at the time of an interrupted process. I also represent a query path into the state of the process. As a StringHolder, the string to be viewed is the interrupted method at some point in the sequence of message-sends that have been initiated but not completed.'!
!Debugger methodsFor: 'initialize-release'!
defaultBackgroundColor
^ #lightRed!
expandStack
"This initialization occurs when the interrupted context is to modelled by
a DebuggerView, rather than a NotifierView (which can not display
'I am a StandardSystemView that provides initialization methods (messages to myself) to create and schedule the interface to an interrupted process, a Debugger.'!
"Answer a standard system view containing an instance of me on the model, aDebugger. The label is aString. Do not terminate the current active process. "
'A place where to-do lists, notes to one another, etc., can be centralized. 1/27/96 sw'!
!DevelopmentSupport class methodsFor: 'scott's notes'!
changeSorterToDoList
"Last changed: 2/7/96 sw"
"Need some relief for the property that when you reactivate a ChangeSorter, all unsubmitted edits in either text pane are summarily discarded (and also, it can take a long time to activate because the changesets are being updated
The menus are not necessarily up to date with other code-browsing menus.
Make sure the initial size/shape will fit okay on the current screen.
No protection against duplicate changeset names
No guarding against empty reply to changeset name.
Nice to have a single-change-sorter as well as Ted's Dual one.
"
!
filesToDo
"2/3/96 sw
The file browser sucks in numerous ways.
One totally brain-damaged thing is that when you try to dismiss it, if there have been edits, you're asked 'is it okay to cancel changes', and when you say yes, it reads in the entire damned file again, just in time to close it.
Upgrade its menus.
Don't read in the entire damned file every time you move the window!!
"!
scottsToDoList
"Last changed: 2/7/96 sw"
"Force popup menus onto screen. Somehow they aren't protected from going off the bottom.
Open new windows properly stacked and never off-screen
Close all unchanged windows. (fix the sucker)
Sys browser window titles change with selected class
Dan's pane resizers
References in inspectListController.
Fix the indent/outdent
Remove Mac stuff and generally Toolbox access, or at least flag it.
When you remove a method, it shows up in change sorter as a removal, but versions doesn't work. Might be nice to stash the version backpointer in the change token so that versions could be made to work...
Resolution about mac scrollbars
Fix weirdo behavior in scrollbars mentioned by Ted.
Ted's look back for uppercase pair at word start
"! !Set subclass: #Dictionary
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Unordered'!
NewDictionary comment:
'I represent a set of elements that can be viewed from one of two perspectives: a set of associations, or a set of values that are externally named where the name can be any object that responds to =. The external name is referred to as the key.'!
"If the receiver includes the given key, evaluate trueBlock, else evaluate falseBlock. 6/7/96 sw"
self noteToDan. "After the three hundredth time I submitted a method as if this glue existed, and then had to put parentheses around the includesKey: clause, I though it might be expedient to have this crutch available. However, perhaps one could think of it as damaging because it would tempt people to assume you could do this elsewhere?!! What do you think?"
^ (self includesKey: aKey)
ifTrue:
[trueBlock value]
ifFalse:
[falseBlock value]!
occurrencesOf: anObject
"Answer how many of the receiver's elements are equal to anObject."
"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches the key. Answer the index of that slot or zero if no slot is found within the given range of indices."
| element |
"this speeds up a common case: key is in the first slot"
"Set all bits in the receiver's area defined by aRectangle to white (zeros)."
self fill: aRectangle rule: Form over fillColor: self white!
fillWithColor: aColor
"Fill the receiver's bounding box with the given color. 5/15/96 sw. Subsequently fixed by tk to be compatible with changed color definition. 7/31/96 sw: code tightened"
self fill: self boundingBox fillColor:
(aColor class == Symbol ifTrue: [Color perform: aColor] ifFalse: [aColor])!
reverse
"Change all the bits in the receiver that are white to black, and the ones
that are black to white."
self fill: self boundingBox rule: Form reverse fillColor: self highLight!
reverse: aRectangle
"Change all the bits in the receiver's area that intersects with aRectangle
that are white to black, and the ones that are black to white."
self fill: aRectangle rule: Form reverse fillColor: self highLight!
reverse: aRectangle fillColor: aMask
"Change all the bits in the receiver's area that intersects with aRectangle
according to the mask. Black does not necessarily turn to white, rather it
changes with respect to the rule and the bit in a corresponding mask
location. Bound to give a surprise."
self fill: aRectangle rule: Form reverse fillColor: aMask! !
!DisplayMedium methodsFor: 'bordering'!
border: aRectangle width: borderWidth
"Paint a border whose rectangular area is defined by aRectangle. The
width of the border of each side is borderWidth. Uses Form black for
drawing the border."
self border: aRectangle width: borderWidth fillColor: Color black!
clippingBox: sourceRect rule: Form under fillColor: nil]!
doesDisplaying
^true! !Form subclass: #DisplayScreen
instanceVariableNames: 'clippingBox '
classVariableNames: 'ScreenSave '
poolDictionaries: ''
category: 'Graphics-Display Objects'!
DisplayScreen comment:
'There is only one instance of me, Display. It is a global and is used to handle general user requests to deal with the whole display screen.
Although I offer no protocol, my name provides a way to distinguish this special instance from all other Forms. This is useful, for example, in dealing with saving and restoring the system.
To change the depth of your Display...
Display newDepth: 16.
Display newDepth: 8.
Display newDepth: 1.
Valid display depths are 1, 2, 4, 8, 16 and 32. It is suggested that you run with your monitors setting the same, for better speed and color fidelity. Note that this can add up to 4Mb for the Display form. Finally, note that newDepth: ends by executing a ''ControlManager restore'' which currently terminates the active process, so nothing that follows in the doit will get executed.
Depths 1, 2, 4 and 8 bits go through a color map to put color on the screen, but 16 and 32-bit color use the pixel values directly for RGB color (5 and 8 bits per, respectivlely). The color choice an be observed by executing Color fromUser in whatever depth you are using.
instanceVariableNames: 'text textStyle offset form foreColor backColor '
classVariableNames: ''
poolDictionaries: 'TextConstants '
category: 'Graphics-Display Objects'!
DisplayText comment:
'I represent Text whose emphasis changes are mapped to a set of fonts. My instances have an offset used in determining screen placement for displaying. They get used two different ways in the system. In the user interface, they mainly hold onto some text which is viewed by some form of ParagraphEditor. However, as a DisplayObject, they may need to display efficiently, so my instances have a cache for the bits.'!
!DisplayText methodsFor: 'accessing'!
alignedTo: alignPointSelector
"Return a copy with offset according to alignPointSelector which is one of...
#(topLeft, topCenter, topRight, leftCenter, center, etc)"
"Normally only sent to a StandardSystemView, but for casees where a DisplayTextView is used alone, without a superview, in which we make this a no-op, put in so that the Character Recognizer doesn't fail. 8/9/96 sw"! !
"The purpose of this class is to absorb all steam messages and do nothing. This is so ReferenceStream can pretend to write on it while traversing all objects it would normally write. We need to know what those object are. 8/17/96 tk"!
binary
"do nothing"!
nextInt32Put: arg
"do nothing"!
nextNumber: cnt put: num
"do nothing"!
nextStringPut: aString
"do nothing"!
position
"Return any random number. Here is where the real lying begins. We are a DummyStream afterall. 8/17/96 tk"
^ 47 !
subclassResponsibility
"Do nothing. Most messages to class Stream are defined as subclassResponsibility. Just accept them. 8/17/96 tk"
'I encode names and literals into tree nodes with byte codes for the compiler. Byte codes for literals are not assigned until the tree-sizing pass of the compiler, because only then is it known which literals are actually needed. I also keep track of sourceCode ranges during parsing and code generation so I can provide an inverse map for the debugger.'!
!Encoder methodsFor: 'initialize-release'!
fillDict: dict with: nodeClass mapping: keys to: codeArray
| codeStream key |
codeStream _ ReadStream on: codeArray.
keys do:
[:key | dict
at: key
put: (nodeClass new name: key key: key code: codeStream next)]!
'I represent an accessor for a sequence of objects that communicate to the outside world. My instances can contain non-homogenous elements. Assumes streaming on a collection of binary, byte-sized elements. My methods assume that a "word" consists of two-bytes.'!
!ExternalStream methodsFor: 'accessing'!
next: anInteger
"Answer the next anInteger elements of my collection. Must override
because default uses self contents species, which might involve a large
collection."
| newArray |
newArray _ collection species new: anInteger.
1 to: anInteger do: [:index | newArray at: index put: self next].
'The sole purpose of this class is to allow the Browser code pane to evaluate the class variables of the class whose method it is showing. It does this by stuffing a pointer to the classpool dictionary of the class being shown into its own classpool. It does this just around a doIt in the code pane. An instance of FakeClasspool is then used as the receiver of the doIt.'!
!FakeClassPool methodsFor: 'as yet unclassified'!
aReadThis
"The sole purpose of this class is to allow the Browser code pane to evaluate the class variables of the class whose method it is showing. It does this by stuffing a pointer to the classpool dictionary of the class being shown into its own classpool. It does this just around a doIt in the code pane. An instance of FakeClasspool is then used as the receiver of the doIt."! !
'I am a kind of StringHolderController (a ParagraphEditor that adds the doIt, printIt, accept, and cancel commands). The commands accept and cancel are omitted. I provide control for editing the contents of an external file. Additional menu commands are:
fileItIn treat the text selection as though it were the contents of a file and read it into the system
get retrieve the file contents to be the contents of the StringHolder (analogous to cancel)
put save the contents of the StringHolder in the file (analogous to accept)'!
!FileController methodsFor: 'menu messages'!
browseChanges
"Browse the selected file in fileIn format."
self controlTerminate.
model browseChanges.
self controlInitialize!
get
"Get contents of file again, it may have changed. Do this by making the
cancel string be the contents, and doing a cancel."
!FileController class methodsFor: 'class initialization'!
initialize
"Initialize the yellow button pop-up menu for a file controller; this is the same as for a general text widnow, with the addition of the top four file-related items. 5/12/96 sw"
FileYellowButtonMenu _ PopUpMenu labels:
'file it in
put
get
view as hex
browse changes
find...(f)
find again (g)
set search string (h)
do again (j)
undo (z)
copy (c)
cut (x)
paste (v)
do it (d)
print it (p)
inspect it (i)
accept (s)
cancel (l)
more...'
lines: #(5 8 10 13 16 18).
FileYellowButtonMessages _
#(fileItIn put get getHex browseChanges find findAgain setSearchString again undo copySelection cut paste doIt printIt inspectIt accept cancel shiftedYellowButtonActivity)
"FileController initialize"
! !
FileController initialize!
Object subclass: #FileDirectory
instanceVariableNames: 'pathName closed '
classVariableNames: 'DefaultDirectory '
poolDictionaries: ''
category: 'System-Files'!
FileDirectory comment:
'I represent a collection of Files. My instances are uniquely identified by the device or server to which they refer. They may also be found in some other dictionary or FileDirectory, though often this is implicit.'!
'FileDirectories carry a path name, and are capable of a number of file creation and access functions, relating to the directory, or volume indicated by their path name. A FileDirectory can be thought of as a Dictionary whose keys are the local names of files in that directory, and whose values are directory "entries".
"Look for the changes file on the image volume, and make the image volume the default directory. Then look for the sources in the image volume. Install results in SourceFiles. 2/13/96 sw."
to: [:directory :fileName | DefaultDirectory _ directory]! !
!FileDirectory class methodsFor: 'documentation'!
documentation
"Subclasses are expected to implement the following messages which are
implemented as self subclassResponsibility unless otherwise noted.
file accessing
fileClass
[optional] rename:newName:
[default] checkNameOfFile:
(default makes no sense to me; for the abstract anything is okay)
file status
[optional] flush
page accessing
[optional] allocate:after:
[optional] allocateSN
[optional] deallocate:
[optional] freePages
dictionary adding
addNew:
dictionary removing
removeOld:
dictionary enumerating
[optional] next
[default] do:
[optional] reset
directory accessing
[default] versionNumbers
"! !
!FileDirectory class methodsFor: 'name service'!
checkName: fullName fixErrors: flag
FileDirectory convertName: fullName
to: [:directory :fileName | ^ directory checkName: fileName fixErrors: flag]!
convertName: fileName to: volAndNameBlock
"Convert the fileName to a directory object and a local fileName. FileName must be of the form: <path><name> where the optional <path> specifies a known directory and <name> is the file name within that directory."
"Take the file name and convert it into a volume name and a fileName. FileName must be of the form: d:f where the optional d: specifies a known directory and f is the file name within that directory."
The creation and modification times are in seconds since the start of the Smalltalk time epoch. DirFlag is true if the entry is a directory. FileSize the file size in bytes or zero for directories. The primitive returns nil when index is past the end of the directory. It fails if the given pathName is bad."
<primitive: 162>
self primitiveFailed.!
pathNameDelimiter
^ $:! !
!FileDirectory class methodsFor: 'primitive support'!
"Import the file into a GIF file, into HyperSqueak. It had better be in the appropriate format, or you'll regret it!! Places the resulting form into the HyperSqueak picture library, at a key which the short filename up to the first period. 8/17/96 sw
9/18/96 sw: handle no-gif-reader and no-HyperSqueak cases with Informers"
| aKey anImage hsq gifReader |
Smalltalk hyperSqueakPresent ifFalse:
[^ self inform: 'Sorry, HyperSqueak is not present in the current system.'].
(gifReader _ Smalltalk gifReaderClass) == nil ifTrue: [^ self inform: 'Sorry, there is no GIF reader available in the current system.'].
"Import the file into a GIF file. It had better be in the appropriate format, or you'll regret it!! Places the resulting form into the global dictionary GIFImports, at a key which the short filename up to the first period. 7/18/96 sw
9/18/96 sw: fail gracefully if GIF is missing."
| aKey anImage gifReader |
(gifReader _ Smalltalk gifReaderClass) == nil ifTrue: [^ self inform: 'Sorry, there is no GIF reader available in the current system.'].
'I represent a Stream that accesses a FilePage from a File. One use for my instance is to access larger "virtual Strings" than can be stored contiguously in main memory. I restrict the objects stored and retrieved to be Integers or Characters. An end of file pointer terminates reading; it can be extended by writing past it, or the file can be explicitly truncated.
To use the file system for most applications, you typically create a FileStream. This is done by sending a message to a FileDirectory (file:, oldFile:, newFile:, rename:newName:) which creates an instance of me. Accesses to the file are then done via my instance.'!
!FileStream methodsFor: 'accessing'!
contentsOfEntireFile
"Read all of the contents of the receiver."
| s binary |
self readOnly.
binary _ self isBinary.
self reset. "erases knowledge of whether it is binary"
binary ifTrue: [self binary].
s _ self next: self size.
self close.
^s!
dataContents
"Read most of the contents of the receiver."
| s |
s _ self size < 4000
ifTrue: [self next: self size]
ifFalse: [self next: 4000].
self close.
^s!
next
(position >= readLimit and: [self atEnd])
ifTrue: [^nil]
ifFalse: [^collection at: (position _ position + 1)]!
next: anInteger
| newCollection howManyRead increment |
newCollection _ collection species new: anInteger.
howManyRead _ 0.
[howManyRead < anInteger] whileTrue:
[self atEnd ifTrue:
[(howManyRead + 1) to: anInteger do: [:i | newCollection at: i put: (self next)].
'I am the controller of the upper part of a three-part file directory window. My contents may be edited. When accepted, my contents becomes the template for the list of files in the other parts. The template consists of repetitions of file name/pattern followed by a carriage return character. A file pattern is a sequence of characters including at least one asterisk, $*. A file name is a sequence of characters without any asterisks.'!
ifFalse: [^ super dispatchOnCharacter: char with: typeAheadStream]! !StringHolder subclass: #FileTemplateHolder
instanceVariableNames: 'fileList '
classVariableNames: ''
poolDictionaries: ''
category: 'Interface-FileList'!
FileTemplateHolder comment:
'I am a StringHolder that also refers to an instance of FileList. Typically, my contents is the template being edited in an upper pane of a file list window; the instance of FileList is the one whose list appears in the middle pane.'!
"Answer an instance of me whose question is messageString. Once the user provides an answer, then evaluate aBlock. If centered, aBoolean, is false, display the view of the instance at aPoint; otherwise display it with its center at aPoint. "
| newBlank fillInView savedArea |
newBlank _ self new initialize.
newBlank action: aBlock.
newBlank contents: aString.
fillInView _ FillInTheBlankView
on: newBlank
message: messageString
displayAt: aPoint
centered: centered.
savedArea _ Form fromDisplay: fillInView displayBox.
fillInView display.
aString isEmpty
ifFalse: [fillInView lastSubView controller selectFrom: 1 to: aString size].
"Answer an instance of me whose question is messageString. Once the user provides an answer, then evaluate aBlock. If centered, aBoolean, is false, display the view of the instance at aPoint; otherwise display it with its center at aPoint.
2/5/96 sw: This variant tries to avoid obscuring aRect
'I am a StringHolderController for a FillInTheBlankView. The string is information that the user can type in and edit. Upon issuing the accept command, this information is used by my model in the evaluation of an action block.'!
!FillInTheBlankController methodsFor: 'basic control sequence'!
model setAction: true! !StringHolderView subclass: #FillInTheBlankView
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Interface-Menus'!
FillInTheBlankView comment:
'I am a view of a FillInTheBlank. I display a query and an area in which the user can type some information. My instances'' default controller is FillinTheBlankController.'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex pan: pan
"A simple implementation of Chowning's frequency-modulation synthesis technique. The center frequency is varied as the sound plays by changing the increment by which to step through the wave table."
'A rectangular array of pixels, used for holding images. All pictures, including character images are Forms. The depth of a Form is how many bits are used to specify the color at each pixel. The actual bits are held in a Bitmap, whose internal structure is different at each depth. Class Color allows you to deal with colors without knowing how they are actually encoded inside a Bitmap.
The supported depths (in bits) are 1, 2, 4, 8, 16, and 32. The number of actual colors at these depths are: 2, 4, 16, 256, 32768, and 16 million.
Forms are combined using BitBlt. See the comment in class BitBlt. Forms that are have both transparent and opapue areas are MaskedForms. Forms that repeat many times to fill a large destination are InfiniteForms.
colorAt: x@y Returns the abstract color at this location
displayAt: x@y shows this form on the screen
displayOn: aMedium at: x@y shows this form in a Window, a Form, or other DisplayMedium
fillColor: aColor Set all the pixels to the color.
edit launch an editor to change the bits of this form.
pixelValueAt: x@y The encoded color. Depends on the depth.
'!
!Form methodsFor: 'initialize-release'!
fromDisplay: aRectangle
"Create a virtual bit map from a user specified rectangular area on the
display screen. Reallocates bitmap only if aRectangle ~= the receiver's
"Answer the receiver's form. For vanilla Forms, this degenerates to self. Makes several methods that operate on both Forms and MaskedForms much more straightforward. 6/1/96 sw"
^ self!
height
^ height!
offset
offset == nil
ifTrue: [^0 @ 0]
ifFalse: [^offset]!
offset: aPoint
offset _ aPoint!
size
"Answer the number of bits in the receiver's bitmap."
self halt. "Should no longer be used -- use bitsSize instead"
^ self bitsSize!
width
^ width! !
!Form methodsFor: 'copying'!
copy: aRect
"Return a new form which derives from the portion of the original form delineated by aRect."
| newForm |
newForm _ Form extent: aRect extent depth: depth.
^ newForm copyBits: aRect from: self at: 0@0
clippingBox: newForm boundingBox rule: Form over fillColor: nil!
"Only called when a Form is being used as a fillColor. Use a Pattern or InfiniteForm instead for this purpose.
Interpret me as an array of (32/depth) Color pixelValues. BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary. 6/18/96 tk"
"CAUTION: this returns the set in counterclockwise order from north-pointing. For the HyperSqueak work of 6/96, the assumption is that they come in clockwise order, and so a fudging routine, SqueakSupport.reversedFormSetFrom:, is provided. Someday this should be cleaned up.
8/8/96 sw: this variant has a rotationCenter argument, though at the moment it is not used. It will come in as nil if there is no special center, in which case the centroid of the form should be used, as it always is in the current implementation."
| drawing back90 flip quad |
self flag: #noteToTed. "This at the moment is the same as what you fixed up a couple of months ago, and does not actually use the rotationCenter part. 8/9/96 sw"
drawing _ Array new: steps.
steps \\ 4 = 0 ifFalse: ["Can't pull any symmetry tricks, rotate every one"
"Rotate the receiver by the indicated number of degrees. This variant gets a rotation center, but in fact ignores the thing -- awaiting someone's doing the right thing. 8/9/96 sw
Note that rotationCenter should now be easy to include in the offset of the resulting form -- see <Point> rotateBy: angle about: center. Could be even faster by sharing the sin, cos inside rotateBy:. This should really be reversed so that this becomes the workhorse, and rotateBy: calls this with rotationCenter: self boundingBox center. And while we're at it, why not include scaling? 9/19/96 di "
^ self rotateBy: deg!
smear: dir distance: dist
"Smear any black pixels in this form in the direction dir in Log N steps"
"To turn some rectangle on the screen into a MacPaint file do:
| f |
f _ FileStream fileNamed: 'STScreen0'.
Form fromUser macPaintOn: f.
f close.
"!
macPaintOn: stream label: labelDisplayBox
"Write the form to the stream in MacPaint format.
NOTE: this implementation is nearly identical to the equally lengthy macPaintOn: method, from which it was derived (by Frank Ludolph, back in 1988, I believe); if we retain these methods, then surely someone should go to the work of merging them so that there's not so much wasted overlalp. Modified 2/14/96 sw so that non-HFS versions of filestreams can be used also"
ifTrue: [(otherImage center - (otherImage extent*(17-i)//32)
extent: otherImage extent*(17-i)//16)
areasOutside:
(otherImage center - (otherImage extent*(16-i)//32)
extent: otherImage extent*(16-i)//16)]
ifFalse: [nil]]! !
!Form methodsFor: 'coloring'!
clear
"Reset the receiver to all white. Created by Alan for his Ob prototype, 2/96, and now also used in the Obj world, though perhaps one might think about some forms clearing to other than pure white?!!"
instanceVariableNames: 'offset form value initialState '
classVariableNames: ''
poolDictionaries: ''
category: 'Graphics-Editors'!
FormButtonCache comment:
'My instances are used to save information needed to construct the switch in a menu for a FormEditor. A collection of my instances is stored as a class variable of FormMenuView.'!
!FormButtonCache methodsFor: 'accessing'!
form
"Answer the receiver's form, the image of the button on the screen."
^form!
form: aForm
"Set the receiver's form to be the argument."
form _ aForm!
initialState
"Answer the receiver's initial state, on or off."
^initialState!
initialState: aBoolean
"Set the receiver's initial state, on or off, to be the argument."
initialState _ aBoolean!
offset
"Answer the receiver's offset, its relative position for displaying the
button."
^offset!
offset: anInteger
"Set the receiver's offset."
offset _ anInteger!
value
"Answer the receiver's value, the keyboard key that selects the button."
^value!
value: aCharacter
"Set the receiver's key character."
value _ aCharacter! !MouseMenuController subclass: #FormEditor
'I represent the basic editor for creating and modifying Forms. This is intended to be an easy to use general-purpose picture (bitMap) editor. I am a kind of MouseMenuController that creates a yellow button menu for accepting and canceling edits. My instances give up control if the cursor is outside the FormView or if a key on the keyboard is pressed.'!
!FormEditor methodsFor: 'initialize-release'!
initialize
super initialize.
self setVariables.
self initializeYellowButtonMenu!
release
"Break the cycle between the Controller and its view. It is usually not
necessary to send release provided the Controller's view has been properly
released independently."
super release.
form _ nil! !
!FormEditor methodsFor: 'basic control sequence'!
controlInitialize
Cursor blank show.
self normalizeColor: unNormalizedColor.
sensor waitNoButton!
controlTerminate
"Resets the cursor to be the normal Smalltalk cursor."
Cursor normal show.
view updateDisplay! !
!FormEditor methodsFor: 'control defaults'!
controlActivity
super controlActivity.
self dragForm!
isControlActive
^super isControlActive & sensor blueButtonPressed not
& sensor keyboardPressed not! !
!FormEditor methodsFor: 'editing tools'!
block
"Allow the user to fill a rectangle with the gray tone and mode currently
selected."
| rectangle |
rectangle _ Rectangle fromUser: grid.
rectangle isNil
ifFalse: [Display
fill: (rectangle intersect: view insetDisplayBox)
rule: mode
fillColor: color]!
changeGridding
"Allow the user to change the values of the horizontal and/or vertical
grid modules. Does not change the primary tool."
| response gridInteger |
response _
self promptRequest: 'Current horizontal gridding is: '
'I represent a view of a Form. Editing takes place by modifying a working version of the Form. The message accept is used to copy the working version into the Form; the message cancel copies the Form into the working version.'!
!FormHolderView methodsFor: 'initialize-release'!
release
super release.
displayedForm release.
displayedForm _ nil! !
!FormHolderView methodsFor: 'model access'!
changeValueAt: location put: anInteger
"Refer to the comment in FormView|changeValueAt:put:."
'I represent a View whose subViews are Switches (and Buttons and OneOnSwitches) whose actions set the mode, color, and tool for editing a Form on the screen. The default controller of my instances is FormMenuController.'!
!FormMenuView methodsFor: 'initialize-release'!
makeFormEditorMenu
| button buttonCache form aSwitchView aSwitchController|
"Now get those forms into the subviews"
self makeButton: 1. "form source"
self makeConnections: (2 to: 6). "tools"
self makeConnections: (7 to: 10). "modes"
self makeButton: 11. "filing in"
self makeButton: 12. "bit editing"
self makeColorConnections: (13 to: 17). "colors"
self makeGridSwitch: 18. "toggle x"
self makeGridSwitch: 19. "toggle y"
self makeButton: 20. "setting grid"
self makeButton: 21 "filing out"! !
!FormMenuView methodsFor: 'subView access'!
subViewContainingCharacter: aCharacter
"Answer the receiver's subView that corresponds to the key, aCharacter.
Answer nil if no subView is selected by aCharacter."
"When a list pane in a complex window has fairly simple action, you can use an instance of GeneralListController directly. You don't need to make a separate class for your kind of list pane.
The model makes and holds the YellowButtonMenu and the YellowButtonMessages and submits them to this instance using yellowButtonMenu: aSystemMenu yellowButtonMessages: anArray. Having specialized menus is the usual reason for a new subclass for each pane.
When the user clicks on a list item, redButtonActivity sends changeModelSelection: which sends toggleListIndex: to the model.
"!
menuMessageReceiver
"Send all menu messages to the model!!"
^ model! !ListView subclass: #GeneralListView
instanceVariableNames: 'controllerClass '
classVariableNames: ''
poolDictionaries: ''
category: 'Interface-Support'!
!GeneralListView methodsFor: 'everything'!
aReadThis
"When a list pane in a complex window has fairl simple action, you can use an instance of GeneralListView directly. You don't need to make a separate class for your kind of list pane.
The usual reason for having a special class is to supply the default controller class. Here we normally us GeneralListController. However, the user can submit his own class to controllerClass: and use that."!
controllerClass: anObject
controllerClass _ anObject!
defaultControllerClass
"Refer to the comment in View|defaultControllerClass."
controllerClass == nil ifTrue: [self error: 'No one told me about my controller'].
'I represent a display transformation of a GraphicSymbol. Multiple copies of a GraphicSymbol can be displayed at different positions and scales on the screen by making appropriate, multiple, instances of me.'!
!GraphicSymbolInstance methodsFor: 'accessing'!
graphicSymbol
"Answer the graphic symbol that the receiver displays."
^graphicSymbol!
graphicSymbol: aGraphicSymbol
"Set the argument, aGraphicSymbol, to be the graphic symbol that the
Meant to masquerade as a StandardFileStream. Use all the normal methods (for best looks, use method:, methodHeader:, methodBody:, for code). Use verbatim: to put stuff directly. Use command: to put out <br>, etc. Command: it supplies the brackets <>, in normal streams it ignores the data, could be used to bold in Text by recognising 'b', '/b', etc. Caller should use header and trailer."
"Override nextPut and do the < > & character transformation. nextPutAll: calls nextPut."
"Reading expects HTML file and produces normal Smalltalk code."!
command: aString
"Append HTML commands directly without translation. Caller should not include < or >. Note that font change info comes through here!! 4/5/96 tk"
(aString includes: $<) ifTrue: [self error: 'Do not put < or > in arg'].
"We do the wrapping with <> here!! Don't put it in aString."
^ self verbatim: '<', aString, '>'!
header
"append the HTML header. Be sure to call trailer after you put out the data.
4/4/96 tk"
| cr f |
cr _ String with: Character cr.
self command: 'HTML'; verbatim: cr.
self command: 'HEAD'; verbatim: cr.
self command: 'TITLE'.
self nextPutAll: '"', self name, '"'.
self command: '/TITLE'; verbatim: cr.
self command: '/HEAD'; verbatim: cr.
self command: 'BODY'; verbatim: cr.
"Write out tab.gif because it is used when source code is written as html"
f nextPutAll: 'GIF89a≡ !!∙,@äÅY!!■ clip2gif v.0.4 by Yves Piguet;'.
f close].
!
nextChunk
"Answer the contents of the receiver, up to the next terminator character (!!). Imbedded terminators are doubled. Undo and strip out all Html stuff in the stream and convert the characters back. 4/12/96 tk"
"Write the whole string, translating as we go. 4/6/96 tk"
"Slow, but faster than using aString asHtml?"
aString do: [:each | self nextPut: each].!
skipSeparators
"Bsides the normal spacers, also skip any <...>, html commands.
4/12/96 tk"
| did |
[did _ self position.
super skipSeparators.
self unCommand. "Absorb <...><...>"
did = self position] whileFalse. "until no change"
!
trailer
"append the HTML trailer. Call this just before file close.
4/4/96 tk"
| cr |
cr _ String with: Character cr.
self command: '/BODY'; verbatim: cr.
self command: '/HTML'; verbatim: cr.
!
verbatim: aString
"Do not attempt to translate the characters. Use this to override translation in nextPutAll:. User may write HTML directly to the file with this."
^ super nextPutAll: aString
"very tricky!! depends on the fact that StandardFileStream nextPutAll: does not call nextPut, but does a direct write."! !Dictionary subclass: #IdentityDictionary
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Unordered'!
!IdentityDictionary methodsFor: 'private'!
scanFor: key from: start to: finish
"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches the key. Answer the index of that slot or zero if no slot is found within the given range of indices."
| element |
"this speeds up a common case: key is in the first slot"
'I am a SwitchController that keeps the view (typically a SwitchView) highlighted while the model (typically a Switch) carries out the selected behavior.'!
!IndicatorOnSwitchController methodsFor: 'basic control sequence'!
sendMessage
"Refer to the comment in SwitchController|sendMessage."
"Answer the next character in the keyboard buffer without removing it, or nil if it is empty."
^ self characterForKeycode: self primKbdPeek!
keyboardPressed
"Answer true if keystrokes are available."
^self primKbdPeek notNil! !
!InputSensor methodsFor: 'modifier keys'!
commandKeyPressed
"Answer whether the command key on the keyboard is being held down."
^ self primMouseButtons anyMask: 64!
controlKeyPressed
"Answer whether the control key on the keyboard is being held down."
^ self primMouseButtons anyMask: 16!
leftShiftDown
"Answer whether the shift key on the keyboard is being held down. The name of this message is a throwback to the Alto, which had independent left and right shift keys."
^ self primMouseButtons anyMask: 8!
optionKeyPressed
"Answer whether the option key on the keyboard is being held down."
^ self primMouseButtons anyMask: 32! !
!InputSensor methodsFor: 'mouse'!
anyButtonPressed
"Answer whether a mouse button is being pressed."
^self buttons > 0!
blueButtonPressed
"Answer whether only the blue mouse button is being pressed."
^self buttons = 1!
mousePoint
"Answer a Point indicating the coordinates of the current mouse location."
^self primMousePt!
noButtonPressed
"Answer whether any mouse button is not being pressed."
^self anyButtonPressed == false!
redButtonPressed
"Answer whether only the red mouse button is being pressed."
^self buttons = 4!
waitButton
"Wait for the user to press any mouse button and then answer with the
current location of the cursor."
[self anyButtonPressed] whileFalse.
^self cursorPoint!
waitClickButton
"Wait for the user to click (press and then release) any mouse button and
then answer with the current location of the cursor."
self waitButton.
^self waitNoButton!
waitNoButton
"Wait for the user to release any mouse button and then answer with the
current location of the cursor."
[self anyButtonPressed] whileTrue.
^self cursorPoint!
yellowButtonPressed
"Answer whether only the yellow mouse button is being pressed."
^self buttons = 2! !
!InputSensor methodsFor: 'cursor'!
currentCursor
"Answer the instance of Cursor currently displayed."
"NOTE: the command and option keys are specific to the Macintosh and may not have equivalents on other platforms."
keycode = nil ifTrue: [ ^nil ].
keycode class = Character ifTrue: [ ^keycode ]. "to smooth the transition!!"
^ Character value: (keycode bitAnd: 16rFF)!
primCursorLocPut: aPoint
"If the primitive fails, try again with a rounded point."
<primitive: 91>
^ self primCursorLocPutAgain: aPoint rounded!
primCursorLocPutAgain: aPoint
"Do nothing if primitive is not implemented."
<primitive: 91>
^ self!
primInterruptSemaphore: aSemaphore
"Primitive. Install the argument as the semaphore to be signalled whenever the user presses the interrupt key. The semaphore will be signaled once each time the interrupt key is pressed."
<primitive: 134>
^self primitiveFailed!
primKbdNext
<primitive: 108>
^ nil!
primKbdPeek
<primitive: 109>
^ nil!
primMouseButtons
<primitive: 107>
^ 0!
primMousePt
"Primitive. Poll the mouse to find out its position. Return a Point. Fail if
event-driven tracking is used instead of polling. Optional. See Object
documentation whatIsAPrimitive."
<primitive: 90>
^ 0@0!
primReadJoystick: index
"Return the joystick input word for the joystick with the given index in the range [1..16]. Returns zero if the index does not correspond to a currently installed joystick."
<primitive: 146>
^ 0
!
primSetInterruptKey: anInteger
"Primitive. Register the given keycode as the user interrupt key. The low byte of the keycode is the ISO character and its next four bits are the Smalltalk modifer bits <cmd><opt><ctrl><shift>."
"Remove and answer the next key in the keyboard buffer."
^keyboardQueue next!
keyboardPeek
"Answer the next key in the keyboard buffer but do not remove it."
^keyboardQueue peek!
leftShiftDown
"Answer whether the left shift key is down."
^lshiftState ~= 0! !
!InputState methodsFor: 'mouse'!
mouseButtons
"Answer the status of the mouse buttons: an Integer between 0 and 7."
"If queue has a new value and the front queue value has been polled enough, move on to the next mouse button movement. Set a minimum number of times it must be polled before it will change."
ifFalse: [redButtonPollCnt _ -1. "keep it pinned"]].
^bitState bitAnd: 7!
mousePoint
"Answer the coordinates of the mouse location."
^self primMousePt! !
!InputState methodsFor: 'cursor'!
cursorPoint: aPoint
"Set the current cursor position to be aPoint. But don't actually do it,
since Macintosh cursors don't relocate too well."
"self primCursorLocPut: aPoint.
x _ aPoint x.
y _ aPoint y"! !
!InputState methodsFor: 'time'!
currentTime
"Answer the time on the system clock in milliseconds since midnight. "
timeProtect critical: [deltaTime = 0
ifFalse:
[baseTime _ baseTime + deltaTime.
deltaTime _ 0]].
^baseTime! !
!InputState methodsFor: 'private'!
bitState: mask incoming: value
"Set bitState according to the incoming new value. This covers the mouse buttons 1,2,4 and five keyset bits. We queue up the red button bit, so that no mouse clicks are lost."
mask = 1 ifFalse: ["yellow, blue, keyset"
value = 1
ifTrue: [bitState _ bitState bitOr: mask]
ifFalse: [bitState _ bitState bitAnd: -1 - mask]]
ifTrue: ["Red button on mouse"
"bitState must be always the same as the first value on the queue"
redButtonQueue addLast: value.
"poll the method mouseButtons will advance the queue"]!
'I am a kind of StringHolderController (a ParagraphEditor that adds the doIt, printIt, accept, and cancel commands). I modify the response to accept by treating the text in the view as an expression to be evaluated. The result of the evaluation is stored as the value of the model"s currently selected variable.'!
'I am a StringHolderView of the value of the selected variable of the object observed by an Inspector. InspectCodeController is my default controller.'!
'I am a kind of LockedListController for the listView of an InspectorView that creates a yellow button menu so that messages can be sent to the list selection (an object) to create and schedule an InspectView on it.'!
'I am a ListView whose items are the instance variables of the object observed by the Inspect that I view. InspectListController is my default controller.'!
!InspectListView methodsFor: 'updating'!
update: aSymbol
aSymbol == #inspectObject
ifTrue:
[self list: model fieldList.
selection _ model selectionIndex.
self displayView].
aSymbol == #selection ifTrue: [self moveSelectionBox: model selectionIndex]! !
!InspectListView methodsFor: 'controller access'!
defaultControllerClass
^InspectListController! !
!InspectListView methodsFor: 'model access'!
model: anInspector
super model: anInspector.
self list: model fieldList.
selection _ model selectionIndex! !StringHolder subclass: #Inspector
instanceVariableNames: 'object selectionIndex '
classVariableNames: ''
poolDictionaries: ''
category: 'Interface-Inspector'!
Inspector comment:
'I represent a query path into the internal representation of an object. As a StringHolder, the string I represent is the value of the currently selected variable of the observed object.'!
!Inspector methodsFor: 'accessing'!
baseFieldList
"Answer an Array consisting of 'self'
and the instance variable names of the inspected object."
^ (Array with: 'self' with: 'all inst vars')
, object class allInstVarNames!
fieldList
"Answer the base field list plus an abbreviated list of indices."
object class isVariable ifFalse: [^ self baseFieldList].
^ self baseFieldList ,
(object basicSize <= (self i1 + self i2)
ifTrue: [(1 to: object basicSize)
collect: [:i | i printString]]
ifFalse: [(1 to: self i1) , (object basicSize-(self i2-1) to: object basicSize)
collect: [:i | i printString]])!
i1
"This is the max index shown before skipping to the
last i2 elements of very long arrays"
^ 100!
i2
"This is the number of elements to show at the end
of very long arrays"
^ 10!
inspect: anObject
"Initialize the receiver so that it is inspecting anObject. There is no
current selection."
self initialize.
object _ anObject.
selectionIndex _ 0.
contents _ ''!
object
"Answer the object being inspected by the receiver."
^object!
object: anObject
"Set anObject to be the object being inspected by the receiver."
anObject == object
ifTrue: [self update]
ifFalse:
[self inspect: anObject.
self changed: #inspectObject]!
update
"Reshow contents, assuming selected value may have changed."
selectionIndex = 0
ifFalse:
[contents _ self selection printString.
self changed: #selection]! !
!Inspector methodsFor: 'selecting'!
replaceSelectionValue: anObject
"The receiver has a list of variables of its inspected object. One of these
is selected. The value of the selected variable is set to the value,
"The receiver has a list of variables of its inspected object. One of these
is selected. Answer the index into the list of the selected variable."
^selectionIndex!
selectionUnmodifiable
"Answer if the current selected variable is modifiable via acceptance in the code pane. For most inspectors, no selection and a selection of self (selectionIndex = 1) are unmodifiable"
^ selectionIndex <= 2!
toggleIndex: anInteger
"The receiver has a list of variables of its inspected object. One of these
is selected. If anInteger is the index of this variable, then deselect it.
Otherwise, make the variable whose index is anInteger be the selected
item."
selectionIndex = anInteger
ifTrue:
["same index, turn off selection"
selectionIndex _ 0.
contents _ '']
ifFalse:
["different index, new selection"
selectionIndex _ anInteger.
contents _ self selection printString].
self changed: #selection.! !
!Inspector methodsFor: 'code'!
doItReceiver
"Answer the object that should be informed of the result of evaluating a
"Answer an instance of me to provide an inspector for anObject."
^self new inspect: anObject! !StringHolder subclass: #InspectorTrash
instanceVariableNames: 'inspectedObject '
classVariableNames: ''
poolDictionaries: ''
category: 'Interface-Inspector'!
InspectorTrash comment:
'This is here only to allow the trash area at the bottom of an inspector. It is basically a StringHolder except that it knows what about the object being inspect and so can accept doIt and printIt with that object as the receiver.'!
!InspectorTrash class methodsFor: 'instance creation'!
for: x
^ self new inspectedObject: x! !StandardSystemView subclass: #InspectorView
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Interface-Inspector'!
InspectorView comment:
'I am a StandardSystemView that provides initialization methods (messages to myself) to create and schedule the interface to an object Inspector. I have two subViews, an InspectListView and an InspectCodeView.'!
!InspectorView methodsFor: 'miscellaneous'!
initialExtent
"Answer the desired extent for the receiver when it is first opened on the screen. 5/22/96 sw"
'My instances can print the object code of a CompiledMethod in symbolic format. They print into an instance variable, stream, and uses oldPC to determine how many bytes to print in the listing. The inherited variable, sender, is used in an ugly way to hold the method being printed.'!
"Create a file whose name is the argument followed by '.bytes'. Store on
the file the symbolic form of the compiled methods of the class."
| file |
file _ FileStream newFileNamed: class name , '.bytes'.
class selectors do:
[:sel |
file cr; nextPutAll: sel; cr.
(self on: (class compiledMethodAt: sel)) printInstructionsOn: file].
file close
"InstructionPrinter printClass: Parser."
! !Object subclass: #InstructionStream
instanceVariableNames: 'sender pc '
classVariableNames: 'SpecialConstants '
poolDictionaries: ''
category: 'Kernel-Methods'!
InstructionStream comment:
'My instances can interpret the byte-encoded Smalltalk instruction set. They maintain a program counter (pc) for streaming through CompiledMethods. My subclasses are Contexts, which inherit this capability. They store the return pointer in the instance variable sender, and the current position in their method in the instance variable pc. For other users, sender can hold a method to be similarly interpreted. The unclean re-use of sender to hold the method was to avoid a trivial subclass for the stand-alone scanning function.'!
!InstructionStream methodsFor: 'testing'!
willJumpIfFalse
"Answer whether the next bytecode is a jump-if-false."
!InstructionStream class methodsFor: 'class initialization'!
initialize
"Initialize an array of special constants returned by single-bytecode returns."
SpecialConstants _
(Array with: true with: false with: nil)
, (Array with: -1 with: 0 with: 1 with: 2)
"InstructionStream initialize."
! !
!InstructionStream class methodsFor: 'instance creation'!
on: method
"Answer an instance of me on the argument, method."
^self new method: method pc: method initialPC! !
InstructionStream initialize!
Number subclass: #Integer
instanceVariableNames: ''
classVariableNames: 'SinArray '
poolDictionaries: ''
category: 'Numeric-Numbers'!
Integer comment:
'I am a common abstract superclass for all Integer implementations. My implementation subclasses are SmallInteger, LargePositiveInteger, and LargeNegativeInteger.
Integer division consists of:
/ exact division, answers a fraction if result is not a whole integer
// answers an Integer, rounded towards negative infinity
\\ is modulo rounded towards negative infinity
quo: truncated division, rounded towards zero'!
!Integer methodsFor: 'testing'!
benchmark "Time millisecondsToRun: [10 benchmark]
11950 (AST 1.0 3/31 on 8100 (arith & spl prims in primary dispatch)
15100 (AST 1.0 3/20 on 8100 (checkProcessSwitch out of inner loop)
"Treat the argument as a bit mask. Answer whether none of the bits that
are 1 in the argument are 1 in the receiver."
^0 = (self bitAnd: mask)! !
!Integer methodsFor: 'converting'!
asCharacter
"Answer the Character whose value is the receiver."
^Character value: self!
asFloat
"Answer a Float that represents the value of the receiver."
| factor sum |
sum _ 0.0.
factor _ self sign asFloat.
1 to: self size do:
[:i |
sum _ (self digitAt: i) * factor + sum.
factor _ factor * 256.0].
^sum!
asFraction
"Answer a Fraction that represents value of the the receiver."
^Fraction numerator: self denominator: 1!
asInteger
"Answer with the receiver itself."
^self
! !
!Integer methodsFor: 'coercing'!
coerce: aNumber
"Refer to the comment in Number|coerce:."
^ aNumber asInteger!
coerceToPoint
"Coerce the receiver into a point by taking the high order part as the vertical coordinate and the low order part as the horizontal coordinate. The part divisin is at 65536."
"An IOWeakArray is like an Array except that it acts like a weak object (holds weak
pointers) on a ReferenceStream.
In an objectToStoreOnDataStream (externalize) method, putting some objects into an
IOWeakArray is a practical way to write them via ReferenceStream>>nextPutWeak:.
-- 11/15/92 jhm
"! !Object subclass: #KeyboardEvent
instanceVariableNames: 'keyCharacter metaState '
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Processes'!
KeyboardEvent comment:
'I represent a keyboard event consisting of a non-meta key being struck plus the state of the meta keys at that moment. Only InputState creates instances of me.'!
!KeyboardEvent methodsFor: 'accessing'!
keyCharacter
"Answer the keyboard character of the receiver."
^keyCharacter!
metaState
"Answer the state of the special keyboard characters: control, shift, lock."
"Primitive. Answer the value of an indexable field in the receiver. Fail if
the argument (the index) is not an Integer or is out of bounds. Essential.
See Object documentation whatIsAPrimitive."
<primitive: 60>
self digitLength < index
ifTrue: [^0]
ifFalse: [^super at: index]!
digitAt: index put: value
"Primitive. Store the second argument (value) in the indexable field of
the receiver indicated by index. Fail if the value is negative or is larger
than 255. Fail if the index is not an Integer or is out of bounds. Answer
the value that was stored. Essential. See Object documentation
whatIsAPrimitive."
<primitive: 61>
^super at: index put: value!
digitLength
"Primitive. Answer the number of indexable fields in the receiver. This
value is the same as the largest legal subscript. Essential. See Object
documentation whatIsAPrimitive."
<primitive: 62>
self primitiveFailed!
replaceFrom: start to: stop with: replacement startingAt: repStart
"Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
<primitive: 105>
^ super replaceFrom: start to: stop with: replacement startingAt: repStart! !
'My instances represent integers beyond the range of SmallInteger, encoded as an array of 8-bit digits. Care must be taken, when new results are computed, that any value that COULD BE a SmallInteger IS a SmallInteger (see normalize). Several algorithms here were written for a SmallInteger range of 15 bits or less, and should be updated to take advantage of the current 31-bit range.'!
!LargePositiveInteger class methodsFor: 'testing'!
test: n "Time millisecondsToRun: [LargePositiveInteger test: 100] 1916"
| f f1 |
"Test and time mult, div, add, subtract"
f _ n factorial.
f1 _ f*(n+1).
n timesRepeat: [f1 _ f1 - f].
f1 = f ifFalse: [self halt].
n timesRepeat: [f1 _ f1 + f].
f1 // f = (n+1) ifFalse: [self halt].
f1 negated = (Number readFrom: '-' , f1 printString) ifFalse: [self halt].
"Check normalization and conversion to/from SmallInts"
'An instance of me is a simple record of a pointer to another Link. I am an abstract class; my concrete subclasses, for example, Process, can be stored in a LinkedList structure.'!
!Link methodsFor: 'accessing'!
nextLink
"Answer the link to which the receiver points."
^nextLink!
nextLink: aLink
"Store the argument, aLink, as the link to which the receiver refers.
"Answer an instance of me referring to the argument, aLink."
^self new nextLink: aLink! !SequenceableCollection subclass: #LinkedList
instanceVariableNames: 'firstLink lastLink '
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Sequenceable'!
LinkedList comment:
'I represent a collection of links, which are containers for other objects. Using the message sequence addFirst:/removeLast causes the receiver to behave as a stack; using addLast:/removeFirst causes the receiver to behave as a queue.'!
!LinkedList methodsFor: 'accessing'!
first
"Answer the first link. Create an error notification if the receiver is
empty."
self emptyCheck.
^firstLink!
last
"Answer the last link. Create an error notification if the receiver is
empty."
self emptyCheck.
^lastLink!
size
"Answer how many elements the receiver contains."
| tally |
tally _ 0.
self do: [:each | tally _ tally + 1].
^tally! !
!LinkedList methodsFor: 'testing'!
isEmpty
^firstLink == nil! !
!LinkedList methodsFor: 'adding'!
add: aLink
"Add aLink to the end of the receiver's list. Answer aLink."
^self addLast: aLink!
addFirst: aLink
"Add aLink to the beginning of the receiver's list. Answer aLink."
self isEmpty ifTrue: [lastLink _ aLink].
aLink nextLink: firstLink.
firstLink _ aLink.
^aLink!
addLast: aLink
"Add aLink to the end of the receiver's list. Answer aLink."
self isEmpty
ifTrue: [firstLink _ aLink]
ifFalse: [lastLink nextLink: aLink].
lastLink _ aLink.
^aLink! !
!LinkedList methodsFor: 'removing'!
remove: aLink ifAbsent: aBlock
"Remove aLink from the receiver. If it is not there, answer the result of
evaluating aBlock."
| tempLink |
aLink == firstLink
ifTrue: [firstLink _ aLink nextLink.
aLink == lastLink
ifTrue: [lastLink _ nil]]
ifFalse: [tempLink _ firstLink.
[tempLink == nil ifTrue: [^aBlock value].
tempLink nextLink == aLink]
whileFalse: [tempLink _ tempLink nextLink].
tempLink nextLink: aLink nextLink.
aLink == lastLink
ifTrue: [lastLink _ tempLink]].
aLink nextLink: nil.
^aLink!
removeFirst
"Remove the first element and answer it. If the receiver is empty, create
an error notification."
| oldLink |
self emptyCheck.
oldLink _ firstLink.
firstLink == lastLink
ifTrue: [firstLink _ nil. lastLink _ nil]
ifFalse: [firstLink _ oldLink nextLink].
oldLink nextLink: nil.
^oldLink!
removeLast
"Remove the receiver's last element and answer it. If the receiver is
'I am a kind of ScrollController that assumes that the view is a kind of ListView. Therefore, scrolling means moving the items in a textual list (menu) up or down. In addition, I provide the red button activity of determining when the red button is selecting an item in the list.'!
'I represent a special type of Paragraph that is used in the list panes of a browser. I avoid all the composition done by more general Paragraphs, because I know the structure of my Text.'!
!ListParagraph methodsFor: 'composition'!
composeAll
"No composition is necessary once the ListParagraph is created."
lastLine isNil ifTrue: [lastLine _ 0].
"Because composeAll is called once in the process of creating the ListParagraph."
^compositionRectangle width! !
!ListParagraph methodsFor: 'private'!
trimLinesTo: lastLineInteger
"Since ListParagraphs are not designed to be changed, we can cut back the
lines field to lastLineInteger."
lastLine _ lastLineInteger.
lines _ lines copyFrom: 1 to: lastLine!
withArray: anArray
"Modifies self to contain the list of strings in anArray"
'I am an abstract View of a list of items. I provide support for storing a selection of one item, as well as formatting the list for presentation on the screen. My instances'' default controller is ListController.'!
!ListView methodsFor: 'initialize-release'!
initialize
"Refer to the comment in View|initialize."
super initialize.
topDelimiter _ '------------'.
bottomDelimiter _ '------------'.
lineSpacing _ 0.
isEmpty _ true.
self list: Array new! !
!ListView methodsFor: 'list access'!
list
"Answer the list of items the receiver displays."
^list!
list: anArray
"Set the list of items the receiver displays to be anArray."
"Presumably the selection has changed to be anInteger. Deselect the
previous selection and display the new one, highlighted."
selection ~= anInteger
ifTrue:
[selection _ anInteger.
self displaySelectionBox]!
selection
"Have to override normal controller smarts about deselection"
^ 0! !
!ListViewOfMany methodsFor: 'updating'!
update: aSymbol
aSymbol == #allSelections
ifTrue: [^ self displayView; emphasizeView].
^ super update: aSymbol! !Dictionary subclass: #LiteralDictionary
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'System-Compiler'!
LiteralDictionary comment:
'A LiteralDictionary, like an IdentityDictionary, has a special test for equality. In this case it is simple equality between objects of like class. This allows equal Float or String literals to be shared without the possibility of erroneously sharing, say, 1 and 1.0'!
"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches the key. Answer the index of that slot or zero if no slot is found within the given range of indices."
| element |
"this speeds up a common case: key is in the first slot"
((element _ array at: start) == nil or:
[(element key class == key class) and:
[element key = key]])
ifTrue: [ ^ start ].
start + 1 to: finish do: [ :index |
((element _ array at: index) == nil or:
[(element key class == key class) and:
[element key = key]])
ifTrue: [ ^ index ].
].
^ 0
! !LeafNode subclass: #LiteralNode
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'System-Compiler'!
LiteralNode comment:
'I am a parse tree leaf representing a literal string or number.'!
"Set the Macintosh file type and creator info for the file with the given name. Fails if the file does not exist or if the type and creator type arguments are not strings of length 4."
'I represent an access mechanism for a sequencable collection re-ordering or filtering its elements.'!
!MappedCollection methodsFor: 'accessing'!
at: anIndex
^domain at: (map at: anIndex)!
at: anIndex put: anObject
^domain at: (map at: anIndex) put: anObject!
atPin: anIndex
"Return this element of an indexable object. Return the first or last element if index is out of bounds. 6/18/96 tk"
^domain at: (map atPin: anIndex)!
atWrap: anIndex
"Return this element of an indexable object. If index is out of bounds, let it wrap around from the end to the beginning unil it is in bounds. 6/18/96 tk"
^domain at: (map atWrap: anIndex)!
contents
"Answer the receiver's domain for mapping, a Dictionary or
'A transparent Form. It consists of theForm and a one-bit-deep mask. When a MaskedForm is displayed, theForm is transparent where the mask is white, and opaque where the mask is black.
The user may specify a mask explicitly. Or the user may submit only theForm and a color that stands for transparent. Thus a MaskedForm can do blue-screening (also called chroma-keying).
When a user submits theForm with a mask, she must say what happens to the colored bits in the transparent area. They can be removed or not. If the user does not remove the overlap, the bits will be combined using OR with the background, producing strange colors.
Think of theForm as unchanged, but we have to change it behind the user''s back for speed. When the users asks for it, we change it back.
<<ColorMap support in next version. Problem: colorMap belongs to sourceForm, but is used by BitBlt. Messages are sent to destForm or to Bitblt, so sourceForm never gets to install the colorMap.>>
In addition to MaskedForm''s normal use, the user may submit a colorMap. (Normally one does not need to do this.) If you have an 8-bit deep Form that was created with colors other than the standard 256 colors we supply, the user can submit a 256 long Array of Colors. MaskedForm will choose the closest 256 colors it can and display the form using those. transparentPixelValue and transparentColor are in terms of the original unmapped Form. The original Form is transformed by the map at each display. Using a map preserves the colors in case you later want to display the Form at a different depth.
Instance variables:
theForm Internal rep of the Form to be displayed. This may different from the Form submitted, but the original Form is recomputed upon request by using ''form''.
mask A one-bit form. white=transparent, black=opaque.
transparentPixelValue The bit value in the original Form that should be treated as transparent.
colorMap An array of Colors. Size = 2^(maskedForm depth). Stored as a copy, so it can''t change without our knowing about it. If you want to change an entry in the colorMap, make the change in your own array and then call colorMap: again.
rawColorMap A cached internal rep to be sent to BitBlt.
Messages:
colorAt: x@y put: aColor Write a Color into a pixel. (Checks if writing over transparent and changes the mask.)
pixelValueAt: x@y put: i Write a raw pixelValue into a pixel.
transparentColor: aColor Change the transparent color. Alters the mask as needed.
transparentPixelValue: i Specify the transparent color by its internal bit pattern.
form Returns the original form. It is in terms of the colorMap, if one was specified. Transparent pixels once again have the chosen transparent color in them.
colorMap: Install a new color map (normally not needed). A colorMap is an array of Colors. It is depth independent, except that its length should be at least 2^N where N is the pixel depth of the Form. (We try to get away with colorMap being an Array instead of an instance of a separate class.) The map is copied from the one you submit. If you change an entry, you must submit the map again using colorMap:.
Class messages:
form: f mask: m removeOverlap: true create a MaskedForm. Remove the colored pixels in this form from its transparent area.
form: f transparentColor: aColor create a MaskedForm
transparentBorder: aForm Answer an instance of me that looks like aForm, but is transparent in regions near the edge.
transparentFromUser: f Displays the Form and asks the user to click on the color that should be transparent.
'!
!MaskedForm methodsFor: 'access'!
basicForm
"Return the form part of me, regardless of how the transparent color has been replaced with 0. 9/6/96 tk"
^ theForm!
borderWidth: anInteger
theForm borderWidth: anInteger.
mask borderWidth: anInteger!
colorMap
"Map the pixelValues in theForm to the colors is this array. 6/28/96 tk"
^ colorMap!
colorMap: anArray
"Map the pixelValues in theForm through the colors is this array. Array should be 2^(theForm depth) long. If shorter, will be padded. If longer, truncated. Map is cached in rawColorMap. 6/28/96 tk"
"Want 2^^depth, except where huge, except if big map supplied"
rawColorMap _ Bitmap new: mapSize.
colorMap doWithIndex: [:color :ind |
rawColorMap at: ind put: (color pixelWordForDepth: d)].
"Note that we don't supply default colors in the added part of the map. We assume no pixel values are used outside the supplied map." !
depth
^ theForm depth!
form
^ self theForm!
mask
^mask!
offset
^ theForm offset!
offset: aPoint
"Refer to the comment in DisplayObject.offset."
theForm offset: aPoint.
mask offset: aPoint!
rawColorMap
"Map the pixelValues in theForm to the colors is this array. This is what BitBlt wants and is computed for theForm's depth. 6/28/96 tk"
^ rawColorMap!
theForm
"Return the original Form. Restore it's transparent color if it was zeroed to make the area truly transparent. 6/22/96 tk"
| copy |
transparentPixelValue == nil ifTrue: [^ theForm].
copy _ self deepCopy. "Use one in Object"
copy restoreOverlap.
^ copy theForm "won't recurse because transparentPixelValue is now nil"!
theFormReally
^ theForm!
transparentColor
"Return the color that is being used as transparent. Not all pixels with this color are transparent if there is more than one internal pixelValue for this color. 6/21/96 tk"
transparentPixelValue == nil ifTrue: [^ nil].
^ Color colorFromPixelValue: transparentPixelValue depth: theForm depth!
transparentColor: aColor
"Change the transparent color. Alters the mask as needed. Checks to see if more than one code used in theForm has this color. If so, asks the user to click on the color that should be transparent.
1. recompute original form
2. change transp color
3. compute new theForm and mask
6/21/96 tk"
self restoreOverlap. "recompute the original colors in theForm"
self setForm: theForm transparentColor: aColor
!
transparentPixelValue
"The internal pixel value (for this depth) that is being used to stand for transparent. 6/21/96 tk"
^ transparentPixelValue
!
transparentPixelValue: pixVal
"Specify the transparent color by its internal raw bit pattern. Changes the transparent color. Alters the mask as needed.
1. recompute original form
2. change transp color
3. compute new theForm and mask
6/21/96 tk"
self restoreOverlap. "recompute the original colors in theForm"
"Create and schedule a view located in an area designated by the user that contains a view of the receiver magnified by 8@8 that can be modified using the Bit Editor. It also contains a view of the original form."
BitEditor openOnForm: self
"MaskedForm makeStar bitEdit."! !
!MaskedForm methodsFor: 'pattern'!
applyColorMap
"Convert theForm to the best approximation of the colors in colorMap. Then make the map be nil. Informaion will be lost. Converts the arbitrary 256 colors in the picture (via the map) to the standard 256 colors. When colorMaps are fully supported, stop using this. 7/1/96 tk"
| port |
port _ BitBlt toForm: theForm.
port colorMap: self rawColorMap.
theForm displayOnPort: port at: 0@0.
"Write over self using the transforming color map"
colorMap _ nil.!
colorAt: aPoint
"Answer the color at the receiver's position aPoint. If transparent there, return the color being used for transparent. (Watch out for two colors with the same value). 6/20/96 tk"
^ Color colorFromPixelValue: pix depth: theForm depth!
colorAt: aPoint put: aColor
"Store the color at the receiver's position aPoint. Assumed to be opaque (so correct color will show) unless it is the value used for transparent. 6/22/96 tk"
^ self pixelValueAt: aPoint
put: (aColor pixelValueForDepth: theForm depth)
!
pixelValueAt: aPoint
"Answer the value at the receiver's position aPoint. Adjust so transparent value is correct. 6/20/96 tk"
"Store the value at the receiver's position aPoint. Assumed to be opaque (so correct color will show) unless it is the values used for transparent. 6/20/96 tk"
"Pass this message on to the receiver's figure form. 6/10/96 sw
Watch out if not changing the mask at the same time. See colorAt:Put: 6/26/96 tk"
theForm fillWithColor: aColor.
mask fillWithColor: Color black.! !
!MaskedForm methodsFor: 'scaling'!
magnify: aRectangle by: scale
"Answer an MaskedForm created as a multiple of the receiver; the result is smaller. Each bit in the new form corresponds to scale number of bits in the receiver."
^ MaskedForm new setForm: (theForm magnify: aRectangle by: scale)
"Answer an MaskedForm created as a multiple of the receiver; the result is smaller. Each bit in the new form corresponds to scale number of bits in the receiver."
^MaskedForm new setForm: (theForm shrink: aRectangle by: scale)
"For compatibility with old OpaqueForms that are files, only read what they have."
" nil allowed also in these fields.
transparentPixelValue _ Integer readFrom: file.
colorMap _ Array readFrom: file.
rawColorMap _ Bitmap readFrom: file.
"!
writeOn: file
"Write the receiver out on the given file, in a format which can be subsequently read back in by the companion method readFrom:. By di 5/96; lost in the color transition, recreated 7/10/96 tk"
theForm writeOn: file.
mask writeOn: file! !
!MaskedForm methodsFor: 'setup'!
removeOverlap
"Erase everything in theForm where the mask is tansparent (white). Often what you want when theForm is more than one bit deep. Modifies the theForm. 6/20/96 tk."
mask reverse.
mask displayOn: theForm
at: 0@0
clippingBox: theForm boundingBox
rule: Form erase1bitShape
fillColor: nil.
mask reverse. "back to original"
!
restoreOverlap
"Put back the transparentPixelValue in theForm where the mask is tansparent (white). Undo what removeOverlap did. Current transparent area must not have any colors in it now (must be 0). Modifies the theForm. 6/20/96 tk."
transparentPixelValue == nil ifTrue: [
^ self error: 'Don''t know what color it was.'].
mask reverse.
mask displayOn: theForm
at: 0@0
clippingBox: theForm boundingBox
rule: Form paint
fillColor: (Color new pixelValue: transparentPixelValue
toBitPatternDepth: theForm depth).
mask reverse. "back to original"
transparentPixelValue _ nil.!
setForm: form mask: m removeOverlap: remove
"Install the form and the mask. theForm is transparent where the mask is white, and opaque where the mask is black. If remove is true, remove the colored pixels in this Form from its transparent area. 6/20/96 tk"
theForm _ form.
mask _ m.
theForm extent = mask extent ifFalse: [
self error: 'mask must be same size.'].
mask depth = 1 ifFalse: [
mask = theForm
ifTrue: [^ self class transparentBorder: theForm]
ifFalse: [^ self error: 'make the mask be 1 bit deep']].
"Use form:transparentColor:"
remove ifTrue: [self removeOverlap].
!
setForm: form mask: m removeOverlap: remove transpPixVal: p
"Install the form and the mask. theForm is transparent where the mask is white, and opaque where the mask is black. If remove is true, remove the colored pixels in this Form from its transparent area. 6/20/96 tk"
theForm _ form.
mask _ m.
transparentPixelValue _ p.
theForm extent = mask extent ifFalse: [
self error: 'mask must be same size.'].
mask depth = 1 ifFalse: [
mask = theForm
ifTrue: [^ self class transparentBorder: theForm]
ifFalse: [^ self error: 'make the mask be 1 bit deep']].
"Use form:transparentColor:"
remove ifTrue: [self removeOverlap].
!
setForm: aForm transparentColor: aColor
"Create a MaskedForm with transparent where aColor is. Substitute 0 into theForm where the mask is 1. 6/21/96 tk"
| d |
theForm _ aForm.
aColor == nil ifTrue: [
"no transparency, take whole form, don't mask off any of it."
mask _ Form extent: theForm extent offset: theForm offset.
mask fillWithColor: #black.
^ self].
d _ theForm depth.
transparentPixelValue _ aColor pixelValueForDepth: d.
mask _ Form extent: theForm extent offset: theForm offset.
Generally, the system does not use instances of Message for efficiency reasons. However, when a message is not understood by its receiver, the interpreter will make up an instance of me in order to capture the information involved in an actual message transmission. This instance is sent it as an argument with the message doesNotUnderstand: to the receiver.'!
!Message methodsFor: 'accessing'!
argument
"Answer the first (presumably sole) argument"
^args at: 1!
argument: newValue
"Change the first argument to newValue and answer self"
args at: 1 put: newValue!
arguments
"Answer the arguments of the receiver."
^args!
selector
"Answer the selector of the receiver."
^selector!
sends: aSelector
"answer whether this message's selector is aSelector"
^selector == aSelector! !
!Message methodsFor: 'printing'!
printOn: aStream
"Refer to the comment in Object|printOn:."
aStream nextPutAll: 'a Message with selector: '.
selector printOn: aStream.
aStream nextPutAll: ' and arguments: '.
args printOn: aStream.
^aStream!
storeOn: aStream
"Refer to the comment in Object|storeOn:."
aStream nextPut: $(.
aStream nextPutAll: 'Message selector: '.
selector storeOn: aStream.
aStream nextPutAll: ' arguments: '.
args storeOn: aStream.
aStream nextPut: $)! !
!Message methodsFor: 'private'!
setSelector: aSymbol arguments: anArray
selector _ aSymbol.
args _ anArray! !
!Message methodsFor: 'sending'!
sentTo: receiver
"answer the result of sending this message to receiver"
'I am a BrowserListView whose items are the message categories of the currently selected class in the Browser I view. MessageCategoryListController is my default controller.'!
!MessageCategoryListView methodsFor: 'updating'!
getList
"Refer to the comment in BrowserListView|getList."
singleItemMode
ifTrue: [^Array with: model selectedMessageCategoryName asSymbol]
ifFalse: [^model messageCategoryList]!
list: anArray
super list: anArray.
list numberOfLines = 3 ifTrue: [
controller isNil ifFalse: [
controller changeModelSelection: 1]].
!
update: aSymbol
(aSymbol == #systemCategorySelectionChanged) |
(aSymbol == #editSystemCategories)
ifTrue: [self resetAndDisplayView. ^self].
(aSymbol == #classSelectionChanged)
ifTrue: [self getListAndDisplayView. ^self].
(aSymbol == #messageCategorySelectionChanged)
ifTrue: [self moveSelectionBox: model messageCategoryListIndex. ^self]! !
'I am a BrowserListView whose items are the messages of the currently selected message category of the currently selected class in the Browser I view. MessageListController is my default controller.'!
!MessageListView methodsFor: 'updating'!
displayView
"Refer to the comment in View|displayView."
| aClass sel index baseClass |
Browser postOpenSuggestion == nil ifFalse: [
"Set the class and message"
aClass _ Browser postOpenSuggestion first.
sel _ Browser postOpenSuggestion last.
Browser postOpenSuggestion: nil.
baseClass _ aClass theNonMetaClass.
index _ SystemOrganization numberOfCategoryOfElement: baseClass name.
model metaClassIndicated: aClass isMeta.
model systemCategoryListIndex: index.
model metaClassIndicated: aClass isMeta.
model classListIndex: ((SystemOrganization listAtCategoryNumber: index)
findFirst: [:each | each == baseClass name]).
sel notNil ifTrue: [
index _ aClass organization numberOfCategoryOfElement: sel.
If special>0, I compile special code in-line instead of sending messages with literal methods as remotely copied contexts.'!
!MessageNode methodsFor: 'initialize-release'!
receiver: rcvr selector: selNode arguments: args precedence: p
"Decompile."
self receiver: rcvr
arguments: args
precedence: p.
special _ MacroSelectors indexOf: selNode key.
selector _ selNode.
"self pvtCheckForPvtSelector: encoder" "We could test code being decompiled, but the compiler should've checked already. And where to send the complaint?"!
receiver: rcvr selector: selName arguments: args precedence: p from: encoder
"Compile."
self receiver: rcvr
arguments: args
precedence: p.
special _ MacroSelectors indexOf: selName.
(self transform: encoder)
ifTrue:
[selector isNil
ifTrue: [selector _ SelectorNode new
key: (MacroSelectors at: special)
code: #macro]]
ifFalse:
[selector _ encoder encodeSelector: selName.
rcvr == NodeSuper ifTrue: [encoder noteSuper]].
self pvtCheckForPvtSelector: encoder!
receiver: rcvr selector: selName arguments: args precedence: p from: encoder sourceRange: range
'I represent a query path of the retrieval result of making a query about methods in the system. The result is a set of methods, denoted by a message selector and the class in which the method was found. As a StringHolder, the string I represent is the source code of the currently selected method. I am typically viewed in a Message Set Browser consisting of a MessageListView and a BrowserCodeView.'!
!MessageSet methodsFor: 'message list'!
messageList
"Answer the current list of messages."
^messageList!
messageListIndex: anInteger
"Set the index of the selected item to be anInteger."
"Create and schedule a message browser with the edited, but not yet
accepted, code (aString) displayed in the text view part of the browser."
^self buildMessageBrowserEditString: aString! !
!MessageSet methodsFor: 'class list'!
metaClassIndicated
"Answer the boolean flag that indicates whether
this is a class method."
^ self selectedClassOrMetaClass isMeta!
selectedClass
"Return the base class for the current selection. 1/17/96 sw fixed up so that it doesn't fall into a debugger in a msg browser that has no message selected"
| aClass |
^ (aClass _ self selectedClassOrMetaClass) == nil
ifTrue:
[nil]
ifFalse:
[aClass theNonMetaClass]!
selectedClassOrMetaClass
"Answer the currently selected class (or metaclass)."
messageListIndex = 0 ifTrue: [^nil].
self setClassAndSelectorIn: [:c :s | ^c]!
selectedMessageCategoryName
"Answer the name of the selected message category or nil."
'My instances add instance-specific behavior to various class-describing objects in the system. This typically includes messages for initializing class variables and instance creation messages particular to a class. There is only one instance of a particular Metaclass, namely the class which is being described. A Metaclass shares the class variables of its instance.
[Subtle] In general, the superclass hierarchy for metaclasses parallels that for classes. Thus,
Integer superclass == Number, and
Integer class superclass == Number class.
However there is a singularity at Object. Here the class hierarchy terminates, but the metaclass hierarchy must wrap around to Class, since ALL metaclasses are subclasses of Class. Thus,
Object superclass == nil, and
Object class superclass == Class.'!
!Metaclass methodsFor: 'initialize-release'!
instanceVariableNames: instVarString
"Declare additional named variables for my instance."
| newMeta invalid ok |
newMeta _ self copyForValidation.
invalid _ newMeta
subclassOf: superclass
oldClass: self
instanceVariableNames: instVarString
variable: false
words: true
pointers: true
ifBad: [^false].
(invalid "But since invalid doesn't get set by adding instVars..."
"Answer whether the receiver's method submisions and class defintions should be logged to the changes file and to the current change set. The metaclass follows the rule of the class itself. 6/18/96 sw"
"Answer whether code submitted for the receiver should be remembered by the changeSet mechanism.The metaclass follows the rule of the class itself. 7/12/96 sw"
^ thisClass wantsChangeSetLogging! !
!Metaclass methodsFor: 'fileIn/Out'!
definition
"Refer to the comment in ClassDescription|definition."
'My instances hold all the dynamic state associated with the execution of a CompiledMethod. In addition to their inherited state, this includes the receiver, a method, and temporary space in the variable part of the context.
MethodContexts, though normal in their variable size, are actually only used in two sizes, small and large, which are determined by the temporary space required by the method being executed.'!
!MethodContext methodsFor: 'initialize-release'!
restart
"Reinitialize the receiver so that it is in the state it was at its creation."
pc _ method initialPC.
stackp _ method numArgs + method numTemps!
restartWith: aCompiledMethod
"Reinitialize the receiver as though it had been for a different method.
Used by a Debugger when one of the methods to which it refers is
recompiled."
method _ aCompiledMethod.
^self restart! !
!MethodContext methodsFor: 'accessing'!
home
"Refer to the comment in ContextPart|home."
^self!
method
^method!
receiver
"Refer to the comment in ContextPart|receiver."
^receiver!
removeSelf
"Nil the receiver pointer and answer its former value."
| tempSelf |
tempSelf _ receiver.
receiver _ nil.
^tempSelf!
tempAt: index
"Refer to the comment in ContextPart|tempAt:."
^self at: index!
tempAt: index put: value
"Refer to the comment in ContextPart|tempAt:put:."
^self at: index put: value! !
!MethodContext methodsFor: 'private'!
setSender: s receiver: r method: m arguments: args
"Create the receiver's initial state."
sender _ s.
receiver _ r.
method _ m.
pc _ method initialPC.
stackp _ method numTemps.
1 to: args size do: [:i | self at: i put: (args at: i)]! !
"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches the key. Answer the index of that slot or zero if no slot is found within the given range of indices."
| element |
"this speeds up a common case: key is in the first slot"
'I am a class of controllers that put the poor user into a mode. They do so by always wanting control and never giving it up. However, they do pass control onto their underlings if any. The underlings are the only ones who can break the mode by sending controlTerminate. But beware, if restarted they continue the mode. Watch out Larry Tesler, the mode lives on...'!
!ModalController methodsFor: 'mode access'!
close
"Enter the mode, the controller will hold controll forever..."
modeActive _ false.!
enterMode
"Enter the mode, the controller will hold controll forever..."
modeActive _ true.!
exitMode
"Enter the mode, the controller will hold controll forever..."
modeActive _ false.!
isModeActive
^ modeActive! !
!ModalController methodsFor: 'control defaults'!
controlInitialize
self enterMode.
^ super controlInitialize!
controlTerminate
self exitMode.
^ super controlTerminate!
isControlActive
^ modeActive!
isControlWanted
^ modeActive! !Object subclass: #Model
instanceVariableNames: 'dependents '
classVariableNames: ''
poolDictionaries: ''
category: 'Interface-Framework'!
Model comment:
'Provides a superclass for classes that function as models. The only behavior provided is fast dependents maintentance, which bypasses the generic DependentsFields mechanism. 1/23/96 sw'!
!Model methodsFor: 'dependents'!
addDependent: anObject
"Add anObject as one of the receiver's dependents. Uniform with generic #addDependent:, returns the newly-object dependent, though this feature is not used anywhere in the base system. 1/23/96 sw"
dependents == nil
ifTrue:
[dependents _ OrderedCollection with: anObject]
ifFalse:
[dependents add: anObject].
^ anObject!
breakDependents
"Reset the user's dependents list. 1/23/96 sw"
dependents _ nil!
dependents
"Answer an OrderedCollection of the objects that are dependent on the receiver, that is, the objects that should be notified if the receiver changes. Always returns a collection, even if empty. 1/23/96 sw"
'I am a Controller that modifies the scheduling of user activities so that the three mouse buttons can be used to make selections or display menus. The menu items are unary messages to the value of sending my instance the message menuMessageReceiver.'!
!NotifyStringHolderController class methodsFor: 'class initialization'!
debugger: aDebugger
^ self new setDebugger: aDebugger! !
!NotifyStringHolderController class methodsFor: 'instance creation'!
initialize
YellowButtonMenu _
PopUpMenu labels:
'proceed
debug'.
YellowButtonMessages _ #(proceed debug )
"NotifyStringHolderController initialize"! !
NotifyStringHolderController initialize!
Magnitude subclass: #Number
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Numeric-Numbers'!
Number comment:
'I am an abstract representation of a number. My subclasses--Float, Fraction, and Integer, or their subclasses--provide concrete representations of a numeric quantity.'!
!Number methodsFor: 'arithmetic'!
* aNumber
"Answer the result of multiplying the receiver by aNumber."
self subclassResponsibility!
+ aNumber
"Answer the sum of the receiver and aNumber."
self subclassResponsibility!
- aNumber
"Answer the difference between the receiver and aNumber."
self subclassResponsibility!
/ aNumber
"Answer the result of dividing receiver by aNumber."
self subclassResponsibility!
// aNumber
"Integer quotient defined by division with truncation toward negative
'I am the superclass of all classes. I provide default behavior common to all objects, such as class access, copying and printing.'!
!Object methodsFor: 'accessing'!
at: index
"Primitive. Assumes receiver is indexable. Answer the value of an
indexable element in the receiver. Fail if the argument index is not an
Integer or is out of bounds. Essential. See Object documentation
whatIsAPrimitive."
<primitive: 60>
index isInteger
ifTrue: [self errorSubscriptBounds: index].
index isNumber
ifTrue: [^self at: index asInteger]
ifFalse: [self errorNonIntegerIndex]!
at: index add: amount
"Add a number to an element of a collection"
self at: index put: (self at: index) + amount!
at: index modify: aBlock
"Replace the element of the collection with itself transformed by the block"
^ self at: index put: (aBlock value: (self at: index))!
at: index put: value
"Primitive. Assumes receiver is indexable. Store the argument value in
the indexable element of the receiver indicated by index. Fail if the
index is not an Integer or is out of bounds. Or fail if the value is not of
the right type for this kind of collection. Answer the value that was
stored. Essential. See Object documentation whatIsAPrimitive."
<primitive: 61>
index isInteger
ifTrue: [(index >= 1 and: [index <= self size])
ifTrue: [self errorImproperStore]
ifFalse: [self errorSubscriptBounds: index]].
index isNumber
ifTrue: [^self at: index asInteger put: value]
ifFalse: [self errorNonIntegerIndex]!
atPin: index
"Return this element of an indexable object. Return the first or last element if index is out of bounds. See Object at:. 6/18/96 tk"
<primitive: 60>
self emptyCheck.
index isInteger ifTrue: [
^ index < 1 ifTrue: [self first] ifFalse: [self last]].
index isNumber
ifTrue: [^self atPin: index asInteger]
ifFalse: [self errorNonIntegerIndex]!
atWrap: index
"Return this element of an indexable object. If index is out of bounds, let it wrap around from the end to the beginning until it is in bounds. See Object at:. 6/18/96 tk"
<primitive: 60>
self size = 0 ifTrue: [self halt].
index isInteger ifTrue: [
^ self at: (index - 1 \\ self size + 1)].
index isNumber
ifTrue: [^self atWrap: index asInteger]
ifFalse: [self errorNonIntegerIndex]!
basicAt: index
"Primitive. Assumes receiver is indexable. Answer the value of an
indexable element in the receiver. Fail if the argument index is not an
Integer or is out of bounds. Essential. Do not override in a subclass. See
Object documentation whatIsAPrimitive."
<primitive: 60>
index isInteger ifTrue: [self errorSubscriptBounds: index].
index isNumber
ifTrue: [^self basicAt: index asInteger]
ifFalse: [self errorNonIntegerIndex]!
basicAt: index put: value
"Primitive. Assumes receiver is indexable. Store the second argument
value in the indexable element of the receiver indicated by index. Fail
if the index is not an Integer or is out of bounds. Or fail if the value is
not of the right type for this kind of collection. Answer the value that
was stored. Essential. Do not override in a subclass. See Object
documentation whatIsAPrimitive."
<primitive: 61>
index isInteger
ifTrue: [(index >= 1 and: [index <= self size])
ifTrue: [self errorImproperStore]
ifFalse: [self errorSubscriptBounds: index]].
index isNumber
ifTrue: [^self basicAt: index asInteger put: value]
ifFalse: [self errorNonIntegerIndex]!
basicSize
"Primitive. Answer the number of indexable variables in the receiver.
This value is the same as the largest legal subscript. Essential. Do not
override in any subclass. See Object documentation whatIsAPrimitive."
<primitive: 62>
"The number of indexable fields of fixed-length objects is 0"
^0 !
bindWithTemp: aBlock
^ aBlock value: self value: nil!
do: aBlock
"Singleton objects just upply themselves to the block"
"This is a convenient way to bind a simple variable
to the result of some expression"
^ aBlock value: self!
readFromString: aString
"Create an object based on the contents of aString."
^self readFrom: (ReadStream on: aString)!
size
"Primitive. Answer the number of indexable variables in the receiver.
This value is the same as the largest legal subscript. Essential. See Object
documentation whatIsAPrimitive."
<primitive: 62>
"The number of indexable fields of fixed-length objects is 0"
^0!
yourself
"Answer self."! !
!Object methodsFor: 'testing'!
hasUnacceptedInput
"Answer if the receiver bears unaccepted input. 3/13/96 sw"
"Answer whether the receiver and the argument represent the same
object. If = is redefined in any subclass, consider also redefining the
message hash."
^self == anObject!
== anObject
"Primitive. Answer whether the receiver and the argument are the same
object (have the same object pointer). Do not redefine the message == in
any other class!! Essential. No Lookup. Do not override in any subclass.
See Object documentation whatIsAPrimitive."
<primitive: 110>
self primitiveFailed!
hash
"Primitive. Answer a SmallInteger whose value is half of the receiver's
object pointer (interpreting object pointers as 16-bit signed quantities).
Fails if the receiver is a SmallInteger. Essential. See Object
documentation whatIsAPrimitive."
<primitive: 75>
self primitiveFailed!
hashMappedBy: map
"Answer what my hash would be if oops changed according to map."
^map newHashFor: self hash!
~= anObject
"Answer whether the receiver and the argument do not represent the
same object."
^self = anObject == false!
~~ anObject
"Answer whether the receiver and the argument are not the same object
(do not have the same object pointer)."
self == anObject
ifTrue: [^ false]
ifFalse: [^ true]! !
!Object methodsFor: 'copying'!
contentsCopy
"Squeak: the receiver, serving as the contents of a Squeak object, wishes to have a suitable copy returned. For most possible contents, the shallow is right; for a collection, i.e. for Folder contents, it is handled in a special-case way. For alias-valued objects, we come to the crux: the receiver, rather than a copy thereof, must be returned. 6/6/96 sw"
^ self shallowCopy release!
copy
"Answer another instance just like the receiver. Subclasses typically
override this method; they typically do not override shallowCopy."
^self shallowCopy!
deepCopy
"Answer a copy of the receiver with its own copy of each instance
variable."
| newObject class index |
class _ self class.
(class == Object) ifTrue: [^self].
class isVariable
ifTrue:
[index _ self basicSize.
newObject _ class basicNew: index.
[index > 0]
whileTrue:
[newObject basicAt: index put: (self basicAt: index) deepCopy.
index _ index - 1]]
ifFalse: [newObject _ class basicNew].
index _ class instSize.
[index > 0]
whileTrue:
[newObject instVarAt: index put: (self instVarAt: index) deepCopy.
index _ index - 1].
^newObject!
kitCopy
^ self shallowCopy!
shallowCopy
"Answer a copy of the receiver which shares the receiver's instance
variables."
| class newObject index |
class _ self class.
"I don't understand why the following check is here. Object is not
supposed to have any instances at all."
class == Object ifTrue: [^self].
class isVariable
ifTrue:
[index _ self basicSize.
newObject _ class basicNew: index.
[index > 0]
whileTrue:
[newObject basicAt: index put: (self basicAt: index).
index _ index - 1]]
ifFalse: [newObject _ class basicNew].
index _ class instSize.
[index > 0]
whileTrue:
[newObject instVarAt: index put: (self instVarAt: index).
index _ index - 1].
^newObject! !
!Object methodsFor: 'dependents access'!
addDependent: anObject
"Add anObject as one of the receiver's dependents."
"Answer a String whose characters are a description of the receiver."
| aStream |
aStream _ WriteStream on: (String new: 100).
self longPrintOn: aStream.
^aStream contents!
printOn: aStream
"Append to the argument, aStream, a sequence of characters that
identifies the receiver."
| title |
title _ self class name.
aStream nextPutAll: ((title at: 1) isVowel
ifTrue: ['an ']
ifFalse: ['a '])
, title!
printString
"Answer a String whose characters are a description of the receiver."
| aStream |
aStream _ WriteStream on: (String new: 100).
self printOn: aStream.
^aStream contents!
storeOn: aStream
"Append to the argument aStream a sequence of characters that is an
expression whose evaluation creates an object similar to the receiver."
aStream nextPut: $(.
self class isVariable
ifTrue: [aStream nextPutAll: '(', self class name, ' basicNew: ';
store: self basicSize;
nextPutAll: ') ']
ifFalse: [aStream nextPutAll: self class name, ' basicNew'].
1 to: self class instSize do:
[:i |
aStream nextPutAll: ' instVarAt: ';
store: i;
nextPutAll: ' put: ';
store: (self instVarAt: i);
nextPut: $;].
1 to: self basicSize do:
[:i |
aStream nextPutAll: ' basicAt: ';
store: i;
nextPutAll: ' put: ';
store: (self basicAt: i);
nextPut: $;].
aStream nextPutAll: ' yourself)'
!
storeString
"Answer a String representation of the receiver from which the receiver
can be reconstructed."
| aStream |
aStream _ WriteStream on: (String new: 16).
self storeOn: aStream.
^aStream contents!
stringRepresentation
"Answer a string that represents the receiver. For most objects this is simply its printString, but for strings themselves, it's themselves. 6/12/96 sw"
^ self printString ! !
!Object methodsFor: 'class membership'!
class
"Primitive. Answer the object which is the receiver's class. Essential. See
Object documentation whatIsAPrimitive."
<primitive: 111>
self primitiveFailed!
isKindOf: aClass
"Answer whether the class, aClass, is a superclass or class of the receiver."
self class == aClass
ifTrue: [^true]
ifFalse: [^self class inheritsFrom: aClass]!
isMemberOf: aClass
"Answer whether the receiver is an instance of the class, aClass."
^self class == aClass!
respondsTo: aSymbol
"Answer whether the method dictionary of the receiver's class contains
aSymbol as a message selector."
^self class canUnderstand: aSymbol! !
!Object methodsFor: 'message handling'!
perform: aSymbol
"Primitive. Send the receiver the unary message indicated by the
argument. The argument is the selector of the message. Invoke
messageNotUnderstood: if the number of arguments expected by the
selector is not zero. Optional. See Object documentation whatIsAPrimitive."
"Primitive. Send the receiver the keyword message indicated by the
arguments. The first argument is the selector of the message. The other
arguments are the arguments of the message to be sent. Invoke
messageNotUnderstood: if the number of arguments expected by the
selector is not three. Optional. See Object documentation
whatIsAPrimitive."
<primitive: 83>
^self perform: aSymbol withArguments: (Array
with: firstObject
with: secondObject
with: thirdObject)!
perform: selector withArguments: anArray
"Primitive. Send the receiver the keyword message indicated by the
arguments. The argument, selector, is the selector of the message. The
arguments of the message are the elements of anArray. Invoke
messageNotUnderstood: if the number of arguments expected by the
selector is not the same as the length of anArray. Essential. See Object
documentation whatIsAPrimitive."
<primitive: 84>
self primitiveFailed! !
!Object methodsFor: 'error handling'!
break: aMessage
"Call break: instead of self halt, you can browse all your breakpoints by browsing senders of #break: The halt is bypassed if the shift key is down. 1/18/96 sw"
Sensor leftShiftDown ifFalse:
[self halt: aMessage]!
caseError
"Report an error from an in-line or explicit case statement."
self error: 'Case not found, and no otherwise clause'!
"See if the message just wants to get at an instance variable of this class. Ask the user if its OK. If so, define the message to read or write that instance or class variable and retry."
| ask newMessage sel |
aMessage arguments size > 1 ifTrue: [^ false].
sel _ aMessage selector asString. "works for 0 args"
aMessage arguments size = 1 ifTrue: [
sel last = $: ifFalse: [^ false].
sel _ sel copyWithout: $:].
(self class instVarNames includes: sel) ifFalse: [
(self class classVarNames includes: sel asSymbol) ifFalse: [
^ false]].
ask _ self confirm: 'A ', thisContext sender sender receiver
"Call this instead of addressing Transcript directly in order to ease identification of all New-Kernel-related Transcript calls obtained (i.e. by browsing senders). 1/18/96 sw"
Transcript cr; show: aString! !
!Object methodsFor: 'flagging'!
flag: aSymbol
"Send this message, with a relevant symbol as argument, to flag a message for subsequent retrieval. For example, you might put the following line in a number of messages:
self flag: #returnHereUrgently
Then, to retrieve all such messages, browse all senders of #returnHereUrgently."
"flags in use currently:
hot (used by sw to flag methods he must revisit; things hotter than hot are flagged #hottest)
developmentNote
scottPrivate
toBeRemoved
noteToDan
noteToJohn
noteToTed"!
isThisEverCalled: msg
"Send this message, with some useful printable argument, from methods or branches of methods which you believe are never reached. 2/5/96 sw"
self halt: 'This is indeed called: ', msg printString! !
!Object methodsFor: 'imported from V'!
comeFullyUpOnReload
"Normally this read-in object is exactly what we want to store. 7/26/96 tk"
^ self!
objectToStoreOnDataStream
"Return an object to store on a data stream (externalize myself)."
^ self!
saveOnFile
"Ask the user for a filename and save myself on a ReferenceStream file.
11/13/92 jhm: Set the file type so it won't appear to be TEXT.
12/2/92 sw: Stash ReferenceStream versionCode at start of file.
Is this ever used??? 7/26/96 tk"
| aFileStream |
aFileStream _ FileStream fromUser.
aFileStream isNil ifTrue: [^ false].
aFileStream binary.
self aboutToWriteToDisk.
(ReferenceStream on: aFileStream)
nextPut: ReferenceStream versionCode;
nextPut: self;
setType;
close.
self doneWritingToDisk!
storeDataOn: aDataStream
"Store myself on a DataStream. Answer self. This is a low-level DataStream/ReferenceStream method. See also objectToStoreOnDataStream.
NOTE: This method must send 'aDataStream beginInstance:size:'
and then put a number of objects (via aDataStream nextPut:/nextPutWeak:).
Cf. readDataFrom:size:, which must read back what this puts
when given the size that it gave to beginInstance:size:. -- 11/15/92 jhm"
| cntInstVars cntIndexedVars |
cntInstVars _ self class instSize.
cntIndexedVars _ self basicSize.
aDataStream
beginInstance: self class
size: cntInstVars + cntIndexedVars.
1 to: cntInstVars do:
[:i | aDataStream nextPut: (self instVarAt: i)].
1 to: cntIndexedVars do:
[:i | aDataStream nextPut: (self basicAt: i)]! !
!Object methodsFor: 'hyperSqueak I/O'!
ioType
"Return which of several categories this object is. Effects how a HyperSqueak object is written on the disk. 7/29/96 tk"
^ #System "non-HyperSqueak object"!
saveOnFile2
"Ask the user for a filename and save myself on a ReferenceStream file.
Put out structure of non-HyperSqueak object. 8/19/96 tk
9/19/96 sw: adjustments for case where HyperSqueak is not present, though this code
at present is not reached except from HyperSqueak code"
| aFileName manager model aStream bytes sqSupport |
aFileName _ self class name asFileName. "do better?"
"Refer to the comment in Class|initialize. This is the initilaize message for Object class, but
if called initialize, then all classes would inherit it as a class message, and clearly this is not
the default desired."
self initializeDependentsFields. "Note this will disconnect views!!"
self initializeErrorRecursion.
self initializeConfirmMenu.
"Object initializeOnceOnly"! !
!Object class methodsFor: 'instance creation'!
newFrom: aSimilarObject
"Create an object that has similar contents to aSimilarObject. If the classes have any instance varaibles with the same names, copy them across. If this is bad for a class, override this method."
| myInstVars similarInstVars any inst good |
myInstVars _ self allInstVarNames.
similarInstVars _ aSimilarObject class allInstVarNames.
inst _ self new.
myInstVars doWithIndex: [:each :index |
good _ similarInstVars indexOf: each.
good > 0 ifTrue: [
inst instVarAt: index put:
(aSimilarObject instVarAt: good).
any _ true]].
any == nil ifTrue: ["not related at all"
self subclassResponsibility].
^ inst!
readFrom: aStream
"Create an object based on the contents of aStream."
[:i | anObject instVarAt: i put: aDataStream next].
1 to: cntIndexedVars do:
[:i | anObject basicAt: i put: aDataStream next].
"self == Association ifTrue: [
anObject value == Obj homeObject ifTrue: [self halt]]."
^ anObject! !Switch subclass: #OneOnSwitch
instanceVariableNames: 'connection '
classVariableNames: ''
poolDictionaries: ''
category: 'Interface-Menus'!
OneOnSwitch comment:
'I am a kind of Switch that can be connected to some related object, typically to a collection of my instances. When my instance is created, its connection is set to a particular object. When the object changes because an Switch it refers to is turned on, an update message is broadcasted. All the connected OneOnSwitches, except the changed one, turn off. This allows OneOnSwitches to maintain the constraint that at most one of them will be on at any time. OneOnSwitches can thus be made to act like "car radio" switches.'!
ifFalse: [^array at: index + firstIndex - 1 put: anObject]!
atPin: anInteger
"Answer my element at index anInteger. at: is used by a knowledgeable client to access an existing element. Return the first or last element if index is out of bounds. 6/18/96 tk"
"Answer my element at index anInteger. at: is used by a knowledgeable client to access an existing element. If index is out of bounds, let it wrap around from the end to the beginning until it is in bounds. 6/18/96 tk"
^ self at: (anInteger - 1 \\ self size + 1)
!
before: oldObject
"Answer the element before oldObject. If the receiver does not contain
oldObject or if the receiver contains no elements before oldObject, create an error notification."
| index |
index _ self find: oldObject.
index = firstIndex
ifTrue: [^ self errorFirstObject]
ifFalse: [^ array at: index - 1]!
first
"Answer the first element. If the receiver is empty, create an errror
message. This is a little faster than the implementation in the superclass."
self emptyCheck.
^ array at: firstIndex!
inspect
"Open an OrderedCollectionInspector on the receiver.
Use basicInspect to get a normal type of inspector."
compositionScanner _ CompositionScanner new in: self.
"If the starting line is not also the first line, then measuring must commence from line preceding the one in which characterInterval start appears. For example, deleting a line with only a carriage return may move characters following the deleted portion of text into the line preceding the deleted line."
startIndex _ (lines at: firstLineIndex) first.
startLine > 1
ifTrue: [newLine _
compositionScanner
composeLine: startLine - 1
fromCharacterIndex: (lines at: startLine - 1) first
inParagraph: self.
(lines at: startLine - 1) = newLine
ifFalse: ["start in line preceding the one with the starting character"
startLine _ startLine - 1.
self lineAt: startLine put: newLine.
startIndex _ newLine last + 1]].
startIndex > text size
ifTrue: ["nil lines after a deletion -- remeasure last line below"
self trimLinesTo: (firstLineIndex - 1 max: 0).
text size = 0
ifTrue: ["entire text deleted -- clear visibleRectangle and return."
'I am a Controller for editing a Paragraph. I am a kind of ScrollController, so that more text can be created for the Paragraph than can be viewed on the screen. Editing messages are sent by issuing commands from a yellow button menu or from keys on the keyboard. My instances keep control as long as the cursor is within the view when the red or yellow mouse button is pressed; they give up control if the blue button is pressed.'!
"If the receiver is lock, do so to the receiver's model. This does something real in StringHolderController, but here it is a no-op, put in so that the Character Recognizer won't fail when used with a vanilla ParagrahEditor. 8/9/96 sw"!
"Replace the text in oldInterval with newText and execute selectingBlock to establish the new selection. Create an undoAndReselect:redoAndReselect: undoer to allow perfect undoing."
"Use for experimental command-key implementation. using this, you can try things out without forever needing to reinitialize the ParagraphEditor. 2/7/96 sw"
self flag: #scottPrivate.
self inform:
'Cmd-t is not currently used.
To get "ifTrue: [" inserted,
use Cmd-SHIFT-t'.
^ true
!
explain
"Try to shed some light on what kind of entity the current selection is.
The selection must be a single token or construct. Insert the answer after
the selection. Send private messages whose names begin with 'explain'
that return a string if they recognize the selection, else nil.
1/15/96 sw: put here intact from BrowserCodeController. But there's too many things that still don't work, as the explain code was very tightly bound with properties of code browsers. So for the moment, in the interest of system integrity, we don't permit. 2/5/96 sw"
[self flag: #noteToTed. "Feel like taking this on? Plenty of things make sense to explain in any text window, but my efforts to elevate the explain facility to more generic use ran out of steam before success."
^ self inform: 'Sorry, explain is currently available
only in code panes. Someday, it may be available
in any text pane. Maybe.'].
newLine _ String with: Character cr.
Cursor execute
showWhile:
[sorry _ '"Sorry, I can''t explain that. Please select a single token, construct, or special character.'.
sorry _ sorry , (model isUnlocked
ifTrue: ['"']
ifFalse: [' Also, please cancel or accept."']).
(string _ self selection asString) isEmpty
ifTrue: [reply _ '']
ifFalse:
[string _ self explainScan: string.
"Remove space, tab, cr"
"Temps and Instance vars need only test strings that are
^'"is a global variable. ' , symbol , ' is a Dictionary. It is a pool which is used by the following classes' , (classes copyFrom: 4 to: classes size) , '"'].
^'"is a global variable. ' , symbol , ' is ' , reply printString , '"'!
explainInst: string
"1/15/96 sw: place holder"
^ nil!
explainMySel: symbol
"1/15/96 sw"
| lits classes |
self flag: #noteToTed. "a halting piece of the generic-explain attempt."
"If a menu command is invoked, typeIn must be closed first, the selection
must be unhighlighted before and rehighlighted after, and the marker
must be updated."
self closeTypeIn.
self deselect.
super performMenuMessage: aSelector.
self selectAndScroll.
self updateMarker!
presentSpecialMenu
"Present a list of expressions, and if the user chooses one, evaluate it in the context of the receiver, a ParagraphEditor. Primarily for debugging, this provides a convenient way to talk to the various views, controllers, and models associated with any text pane. 2/5/96 sw"
"Try to make a selector out of the current text selection.
6/18/96 sw: incorporated Dan's code for hunting down selectors with keyword parts; while this doesn't give a true parse, and will not handle parentheses correctly, for example, in most cases it does what we want, in where it doesn't, we're none the worse for it."
| sel |
sel _ self selection string withBlanksTrimmed.
(sel includes: $:) ifTrue:
[sel _ String streamContents:
[:s | ((sel findTokens: Character separators)
select: [:tok | tok last = $:])
do: [:key | s nextPutAll: key]]].
sel size == 0 ifTrue: [^ nil].
Symbol hasInterned: sel ifTrue:
[:aSymbol | ^ aSymbol].
^ nil!
selectedSymbol
"Return the currently selected symbol, or nil if none. If the selection involves a method send, return the relevent selector. If the selection is a class name, return that. 1/15/96 sw.
2/29/96 sw: strip crs before lookup"
| aString |
startBlock = stopBlock ifTrue: [^ nil].
aString _ self selection string copyWithout: Character cr.
aString size == 0 ifTrue: [^ nil].
Symbol hasInterned: aString ifTrue: [:sym | ^ sym].
^ nil!
sendersOfIt
"Open a senders browser on the selected selector. 1/8/96 sw
1/18/96 sw: converted to use selectedSelector
2/29/96 sw: select current line first, if selection was an insertion pt"
"Answer the menu to be presented when the yellow button is pressed while the shift key is down. 3/13/96 sw
5/27/96 sw: added font menu"
^ PopUpMenu labels:
'set font... (k)
set style... (K)
explain
format
file it in
recognizer (r)
spawn (o)
browse it (b)
senders of it (n)
implementors of it (m)
references to it (N)
selectors containing it (W)
method strings with it
method source with it
special menu...
more...'
lines: #(2 7 14).!
shiftedYellowButtonMessages
"Answer the set of messages that go with the shifted menu. Inconvenient to have it here in this separate method; when/if we consolidate via a class variable, as for unshifted, the problem will go away. 1/17/96 sw
3/7/96 sw: added methodSourceContainingIt
3/13/96 sw: merged ParagraphEditor and StringHolderController versions into ParagraphEditor, and deleted the StringHolderController versions
"Exchange the current and prior selections. Keeps typeahead."
sensor keyboard. "Flush character"
self closeTypeIn: characterStream.
self exchange.
^true!
implementorsOfIt: characterStream
"Triggered by Cmd-m; browse implementors of the selector represented by the current selection, if plausible. 2/1/96 sw"
sensor keyboard. "flush character"
self implementorsOfIt.
^ true!
indent: characterStream
"Add a tab at the front of every line occupied by the selection. Flushes typeahead. Invoked from keyboard via cmd-shift-R. 2/29/96 sw"
^ self inOutdent: characterStream delta: 1!
inOutdent: characterStream delta: delta
"Add/remove a tab at the front of every line occupied by the selection. Flushes typeahead. Derived from work by Larry Tesler back in December 1985. Now triggered by Cmd-L and Cmd-R. 2/29/96 sw"
"The user typed the command key that requests a font change; Offer the font menu. 5/27/96 sw
Keeps typeahead. (?? should flush?)"
sensor keyboard. "flush character"
self closeTypeIn: characterStream.
self offerFontMenu.
^ true!
outdent: characterStream
"Remove a tab from the front of every line occupied by the selection. Flushes typeahead. Invoked from keyboard via cmd-shift-L. 2/29/96 sw"
^ self inOutdent: characterStream delta: -1!
paste: characterStream
"Replace the current text selection by the text in the shared buffer.
Keeps typeahead."
sensor keyboard. "flush character"
self closeTypeIn: characterStream.
self paste.
^true!
pasteInitials: characterStream
"Replace the current text selection by an authorship name/date stamp; invoked by cmd-shift-v, easy way to put an authorship stamp in the comments of an editor.
"Triggered by Cmd-o; spawn a new code window, if it makes sense. Reimplemented by BrowserCodeController 2/1/96 sw"
sensor keyboard. "flush character"
view flash.
^ true!
swapChars: characterStream
"Triggered byCmd-Y;. Swap two characters, either those straddling the insertion point, or the two that comprise the selection. Suggested by Ted Kaehler. 1/18/96 sw"
| currentSelection aString chars |
sensor keyboard. "flush the triggering cmd-key character"
(chars _ self selection) size == 0
ifTrue:
[currentSelection _ startBlock stringIndex]
ifFalse:
[chars size == 2
ifFalse:
[view flash. ^ true]
ifTrue:
[currentSelection _ startBlock stringIndex + 1]].
self selectFrom: currentSelection - 1 to: currentSelection.
"Experimental. Triggered by Cmd-t; put trial cmd-key commands here to see how they work, before hanging them on their own cmd accelerators. 2/7/96 sw "
| currentSelection aString chars |
self flag: #scottPrivate.
sensor keyboard. "flush the triggering cmd-key character"
self experimentalCommand.
^ true!
undo: characterStream
"Undo the last edit. Keeps typeahead, so undo twice is a full redo."
"Recognize hand-written characters and put them into the receiving pane. Invokes Alan's character recognizer. 2/5/96 sw"
| aRecognizer |
Cursor marker showWhile:
[aRecognizer _ CharRecog new.
aRecognizer recognizeAndDispatch:
[:char | char == BS
ifTrue:
[self simulatedBackspace]
ifFalse:
[self simulatedKeystroke: char]]
until:
[(box containsPoint: sensor cursorPoint) not]].
view display!
setEmphasisHere
emphasisHere _ paragraph text emphasisAt: startBlock stringIndex!
simulatedKeystroke: char
"Accept char as if it were struck on the keyboard. This version does not (yet) deal with command keys, and achieves update in the receiver's typically inactive window via the sledge-hammer of uncache-bits. 1/31/96 sw"
"Subroutine of search: and again. If useOldKeys, use same FindText and ChangeText as before. If many is true, do it repeatedly. Created 1/26/96 sw by adding the many argument to #againOrSame."
| home indices wasTypedKey |
home _ self selectionInterval. "what was selected when 'again' was invoked"
"If new keys are to be picked..."
useOldKeys ifFalse: "Choose as FindText..."
[FindText _ UndoSelection. "... the last thing replaced."
"If the last command was in another paragraph, ChangeText is set..."
paragraph == UndoParagraph ifTrue: "... else set it now as follows."
[UndoInterval ~= home ifTrue: [self selectInterval: UndoInterval]. "blink"
'This superclass of most compiler/decompiler classes declares common class variables, default messages, and the code emitters for jumps. Some of the class variables are initialized here; the rest are initialized in class VariableNode.'!
!ParseNode methodsFor: 'testing'!
assignmentCheck: encoder at: location
"For messageNodes masquerading as variables for the debugger.
For now we let this through - ie we allow stores ev
into args. Should check against numArgs, though."
^ -1!
canBeSpecialArgument
"Can I be an argument of (e.g.) ifTrue:?"
^false!
canCascade
^false!
isArg
^false!
isComplex
"Used for pretty printing to determine whether to start a new line"
"If the selector has multiple keywords and there is a place to split where each half is a known selector, then evaluate the successBlock with the two selectors and the index of the keyword after which to split."
| keys strm |
keys _ proposedKeyword keywords.
keys size < 2 ifTrue: [^ nil].
"Try every possible split"
strm _ WriteStream on: (String new: 30).
1 to: keys size-1 do: [:index |
strm reset.
1 to: index do: [:i | strm nextPutAll: (keys at: i)].
"Correct the proposedKeyword to some selector symbol, correcting the original text if such action is indicated. abortAction is invoked if the user the proposedKeyword couldn't be converted into a valid selector. Spots is an ordered collection of intervals within the test stream of the for each of the keyword parts."
and: [(requestor text string at: tempsMark-1) = Character tab].
tabbed
ifTrue: [insertion _ insertion , (String with: Character tab)].
tempsMark _ tempsMark +
(self substituteWord: insertion
wordInterval: (tempsMark to: tempsMark-1)
offset: 0)
- (tabbed ifTrue: [3] ifFalse: [2])].
^ encoder reallyBind: name!
placeToBreak: proposedKeyword
"If the selector has multiple keywords and there is a place to split where each half is a known selector, then return the index of the keyword after which to break, else zero."
| keys strm |
keys _ proposedKeyword keywords.
keys size < 2 ifTrue: [^ 0].
"Try every possible split"
strm _ WriteStream on: (String new: 30).
1 to: keys size-1 do: [:index |
strm reset.
1 to: index do: [:one | strm nextPutAll: (keys at: one)].
Symbol hasInterned: strm contents ifTrue:
[:aSymbol |
strm reset.
index+1 to: keys size do:
[:one | strm nextPutAll: (keys at: one)].
Symbol hasInterned: strm contents ifTrue:
[:another | ^ index "We have a winnah!!"]]].
^ 0 "just a new or misspelled selector"!
restart
"This SHOULD restart compilation, but since the parser
doesnt have access to the corrected text, we have to ask
the user to restart. Sigh."
PopUpMenu notify: 'I was able to make the correction,
'I keep track of the current and high position of the stack that will be needed by code being compiled.'!
!ParseStack methodsFor: 'initialize-release'!
init
length _ position _ 0! !
!ParseStack methodsFor: 'accessing'!
pop: n
(position _ position - n) < 0
ifTrue: [self error: 'Parse stack underflow']!
push: n
(position _ position + n) > length
ifTrue: [length _ position]!
size
^length! !
!ParseStack methodsFor: 'results'!
position
^position! !
!ParseStack methodsFor: 'printing'!
printOn: aStream
super printOn: aStream.
aStream nextPutAll: ' at '; print: position; nextPutAll: ' of '; print: length! !DisplayObject subclass: #Path
instanceVariableNames: 'form collectionOfPoints '
classVariableNames: ''
poolDictionaries: ''
category: 'Graphics-Display Objects'!
Path comment:
'I am the abstract superclass of the Graphic spatial primitives. I represent an ordered sequence of Points. Spatial primitives are used to generate "trajectories" such as lines and circles.'!
!Path methodsFor: 'accessing'!
at: index
"Answer the point on the receiver's path at position index."
^collectionOfPoints at: index!
at: index put: aPoint
"Store the argument, aPoint, as the point on the receiver's path at position
index."
^collectionOfPoints at: index put: aPoint!
atPin: index
"Answer the point on the receiver's path at position index."
^collectionOfPoints atPin: index!
atWrap: index
"Answer the point on the receiver's path at position index."
^collectionOfPoints atWrap: index!
first
"Answer the first point on the receiver's path; included to correspond to
OrderedCollection protocol."
^collectionOfPoints first!
firstPoint
"Answer the first point on the receiver's path."
^collectionOfPoints first!
firstPoint: aPoint
"Replace the first element of the receiver with the new value aPoint.
Answer the argument aPoint."
collectionOfPoints at: 1 put: aPoint.
^aPoint!
form
"Answer the receiver's form, or, if form is nil, then answer a 1 x 1 black
form (a black dot)."
| aForm |
form == nil
ifTrue:
[aForm _ Form extent: 1 @ 1.
aForm fillBlack.
^aForm]
ifFalse:
[^form]!
form: aForm
"Make the argument, aForm, be the receiver's form."
form _ aForm!
last
"Answer the last point on the receiver's path; included to correspond to
OrderedCollection protocol."
^collectionOfPoints last!
offset
"There are basically two kinds of display objects in the system: those
that, when asked to transform themselves, create a new object; and those
that side effect themselves by maintaining a record of the transformation
request (typically an offset). Path, like Rectangle and Point, is a display
object of the first kind."
self shouldNotImplement!
secondPoint
"Answer the second element of the receiver."
^collectionOfPoints at: 2!
secondPoint: aPoint
"Replace the second element of the receiver with the new value aPoint.
Answer the argument aPoint."
collectionOfPoints at: 2 put: aPoint.
^aPoint!
size
"Answer the length of the receiver."
^collectionOfPoints size!
thirdPoint
"Answer the third element of the receiver."
^collectionOfPoints at: 3!
thirdPoint: aPoint
"Replace the third element of the receiver with the new value aPoint.
"Creates a Path from mousePoints and displays it several ways on the display screen. Messes up the display. For learning about class Path, just select the code below and execute it to create a path and see it redisplayed in another place on the screen. Each path displays using a different form. A path is indicated by pressing the red mouse button in a sequence; press any other mouse button to terminate. "
| aPath aForm pl fl flag |
aForm _ Form extent: 2 @ 40. "creates a form one inch long"
aForm fillBlack. "turns it black"
aPath _ Path new.
aPath form: aForm. "use the long black form for displaying"
flag _ true.
[flag]
whileTrue:
[Sensor waitButton.
Sensor redButtonPressed
ifTrue:
[aPath add: Sensor waitButton.
Sensor waitNoButton.
aForm displayOn: Display at: aPath last]
ifFalse: [flag _ false]].
Display fillWhite.
aPath displayOn: Display. "the original path"
pl _ aPath translateBy: 0 @ 100.
fl _ Form extent: 40 @ 40.
fl fillGray.
pl form: fl.
pl displayOn: Display. "the translated path"
Sensor waitNoButton
"Path example"! !Form subclass: #Pattern
instanceVariableNames: 'colorArray2D '
classVariableNames: ''
poolDictionaries: ''
category: 'Graphics-Display Objects'!
Pattern comment:
'A pattern is a halftone of Colors. It is a 2-D array of Colors that is used to get an in-between color by dithering. An Array2D holds a tile of colors that is repeated over and over when filling a Form. Just store one repeat of the tile. A Patterns is used instead of a single Color as the fillColor parameter of BitBlt for filling forms. A Pattern is used either for texture or when no single color looks like the color you want in a low-depth Form. (See InfiniteForm for larger textures.)
Normally a pattern is 2x2 or 4x4 colors.
A Pattern is essentially immutable. Once you set the array of Colors, you should not change them. Instead, create a new Pattern and use it.
Ignore the fact that Pattern is a subclass of Form. (width, height, and bits are used internally to cache the encoded pattern for BitBlt. Don''t use them like you would in a Form.)
pattern an Array2D of Colors to be used as a dither.
depth a cache for the depth this pattern was last displayed at.
Messages:
setExtent: x@y colors: anArray Set up a pattern using data in a 1-D array.
colorArray returns an Array2D of colors.
depth: d recompute the raw bits based on the depth of the destination Form we are about to fill. BitBlt will automatically send this just before using a pattern.
(When a Pattern is displayed, there are restrictions: The number of colors across in X, times the depth must be 32 or less. You can display a 4x4 pattern of colors at 8 bits deep. You can display a 32x32 pattern at 1 bit deep. For 32 bits deep, you should use a single color instead. You can store fewer colors than the max allowed in X, such as a 2x2 pattern at 8 bits deep. If you store more colors than is allowed at the display depth, pattern pixels on the right hand side will not show up.)
Further details you don''t need to know:
The raw halftone supplied to BitBlt is basically an array of 32-bit values. BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary. Within each scan line the 32-bit value is repeated from left to right across the form. The value will produce a halftone that repeats on N-pixel boundaries, N = 32 // depth.'!
!Pattern methodsFor: 'access'!
asColor
"Treat the whole pattern as its average color. The result loses information. 6/20/96 tk"
^ Color r: self red g: self green b: self blue!
asInfiniteForm
"Convert me into a normal Form, but one that knows to repeat when used as a source. Call after sending depth: d. Lose information about the true abstract Colors I have, and only keep information for the current depth. 6/20/96 tk"
"The number of colors in Y in the array. 6/20/96 tk"
^ colorArray2D height!
patWidth
"The number of colors in X. Differs from the 'width', which is what the bit cache is using. 6/20/96 tk"
^ colorArray2D width!
red
"Find the average red of this pattern. 6/20/96 tk"
| sum |
sum _ 0.
colorArray2D do: [:each | sum _ sum + each red].
^ sum / (colorArray2D width * colorArray2D height)! !
!Pattern methodsFor: 'cached bits'!
bitPatternForDepth: newDepth
"The raw call on BitBlt needs a Bitmap to represent this pattern of colors. I already am Bitmap like. See if my cached bits are at the right depth already. If not, recompute. Interpret me as an array of (32/depth) Color pixelValues. BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary. See BitBlt class comment. 6/20/96 tk"
newDepth = depth ifTrue: [^ self]. "cache is good"
self depth: newDepth.
^ self!
cacheBits
"Actual bits must be recomputed and cached for the display depth. Width, that is (extent x), is limited to 32/depth. If shown at a depth that is too wide, right hand side colors will not show.
If you reach in and change a color in colorArray2D, then call this to update the pattern. 6/20/96 tk"
| word row |
depth == nil ifTrue: [self error: 'for what depth?'].
"Set the depth at which this Pattern of Colors will be rendered. The results are cached in depth, width, height, and bits. 6/20/96 tk"
d = depth ifTrue: [^ self]. "trust the cache"
super depth: d.
self cacheBits. "Computer the rendering Bitmap"! !
!Pattern methodsFor: 'private'!
setArray2D: anArray2D
"A grid of Colors that can be used to fill a Form. Actual bits are recomputed for the display depth (and cached). Width is limited to (32/depth). If shown at a depth that is too wide, right hand side colors will not show. 6/20/96 tk"
colorArray2D == nil ifFalse: [
^ self error: 'Can''t change a Pattern. Please make a new one'].
"anArray2D width > 32 ifTrue: [
self error: 'Too wide. Some colors won''t show']."
"OK to use as a route from a big Array of Colors to a Form?"
colorArray2D _ anArray2D.
depth == nil ifFalse: [self cacheBits].!
setExtent: extent colors: anArray
"A grid of Colors that can be used to fill a Form. Initialized from an Array of Colors (x across first row, then second row). Actual bits are recomputed for the display depth (and cached). Width, that is (extent x), is limited to 32/depth. If shown at a depth that is too wide, right hand side colors will not show. 6/20/96 tk"
colorArray2D == nil ifFalse: [
^ self error: 'Can''t change a Pattern. Please make a new one'].
"extent x > 32 ifTrue: [
self error: 'Too wide. Some colors won''t show']."
"Use as a route from a big array of Colors to a Form?"
colorArray2D _ Array2D new extent: extent fromArray: anArray.
"Create a new pattern. A grid of Colors that can be used to fill a Form. Actual bits recomputed for the display depth (and cached). Width, that is (extent x), is limited to 32/depth. If shown at a depth that is too wide, right hand side colors will not show. 6/20/96 tk"
^ self new setArray2D: anArray2D!
extent: extent colors: anArray
"A grid of Colors that can be used to fill a Form. Initialized from an Array of Colors (x across first row, then second row). Actual bits are recomputed for the display depth (and cached). Width, that is (extent x), is limited to 32/depth. If shown at a depth that is too wide, right hand side colors will not show. 6/20/96 tk"
^ self new setExtent: extent colors: anArray
"
((Form extent: 50@50 depth: 8) fillColor:
(Pattern extent: 2@2 colors: (Array
with: Color green with: Color white
with: Color white with: Color green))) display
"! !BitBlt subclass: #Pen
instanceVariableNames: 'frame location direction penDown '
classVariableNames: 'Colors '
poolDictionaries: ''
category: 'Graphics-Primitives'!
Pen comment:
'My instances can scribble on the screen, drawing and printing at any angle. Since I am a BitBlt, scribbling can be done with different source forms.'!
!Pen methodsFor: 'initialize-release'!
defaultNib: widthInteger
"Nib is the tip of a pen. This sets up the pen, with a nib of width
widthInteger. Alternatively, try
roundNib: widthInteger, or
sourceForm: aForm
to set the shape of the tip. For example, try:
| bic | bic _ Pen new sourceForm: Cursor normal.
bic combinationRule: Form paint; turn: 90.
10 timesRepeat: [bic down; go: 10; up; go: 20].
"
self color: destForm black.
self squareNib: widthInteger!
roundNib: widthInteger
"Nib is the tip of a pen. This sets up the pen, with the source form
set to a round dot of diameter widthInteger."
self sourceForm: (Form dotOfSize: widthInteger).
combinationRule _ Form paint!
squareNib: widthInteger
"Sets this pen to draw with a square tip of width widthInteger."
mixSampleCount: n into: aSoundBuffer startingAt: startIndex pan: pan
"The Karplus-Strong plucked string algorithm: start with a buffer full of random noise and repeatedly play the contents of that buffer while averaging adjacent samples. High harmonics damp out more quickly, transfering their energy to lower ones. The length of the buffer corresponds to the length of the string. It may be out of tune for higher pitches because the buffer length must be an integral number of samples and the nearest integer may not result in the exact pitch desired."
"Treating the receiver as a velocity (with negative y meaning up for the time being), return the heading, in degrees, represented. Returns an integer result in the range [0, 359]
"Answer an instance of me with coordinates xInteger and yInteger."
^self new setX: xInteger setY: yInteger! !Object subclass: #PopUpMenu
instanceVariableNames: 'labelString font lineArray frame form marker selection '
classVariableNames: ''
poolDictionaries: ''
category: 'Interface-Menus'!
PopUpMenu comment:
'I represent a list of items. My instances are presented on the display screen in a rectangular area. The user points to an item, pressing a mouse button; the item is highlighted. When the button is released, the highlighted item indicates the selection.'!
!PopUpMenu methodsFor: 'basic control sequence'!
startUp
"Display and make a selection from the receiver as long as the button
is pressed. Answer the current selection."
^ self startUpWithCaption: nil!
startUpCenteredWithCaption: captionOrNil
"Differs from startUpWithCaption: by appearing with cursor in the menu,
and thus ready to act on mouseUp, without requiring user tweak to confirm"
instanceVariableNames: 'collection position readLimit '
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Streams'!
PositionableStream comment:
'I represent an accessor for a sequence of objects (a collection) that are externally named by indices so that the point of access can be repositioned. I am abstract in that I do not implement the messages next and nextPut: which are inherited from my superclass Stream.'!
!PositionableStream methodsFor: 'accessing'!
contents
"Answer with a copy of my collection from 1 to readLimit."
^collection copyFrom: 1 to: readLimit!
last
"Return the final element in the receiver. Put in at Alan's request. 2/2/96 sw"
^ collection at: (position - 1)!
next: anInteger
"Answer the next anInteger elements of the receiver."
| newArray |
newArray _ self contents species new: anInteger.
1 to: anInteger do: [:index | newArray at: index put: self next].
^newArray!
originalContents
"Answer the receiver's actual contents collection, NOT a copy. 1/29/96 sw"
^ collection!
peek
"Answer what would be returned if the message next were sent to the
receiver. If the receiver is at the end, answer nil."
| nextObject |
self atEnd ifTrue: [^nil].
nextObject _ self next.
position _ position - 1.
^nextObject!
peekFor: anObject
"Answer false and do not move over the next element if it is not equal to
the argument, anObject, or if the receiver is at the end. Answer true
and increment the position for accessing elements, if the next element is
equal to anObject."
| nextObject |
self atEnd ifTrue: [^false].
nextObject _ self next.
"peek for matching element"
anObject = nextObject ifTrue: [^true].
"gobble it if found"
position _ position - 1.
^false!
reverseContents
"Answer a copy of the receiver's contents, in reverse order."
| size j newCollection |
size _ j _ collection size.
newCollection _ collection species new: size.
1 to: size do: [:i | newCollection at: i put: (collection at: j). j _ j - 1].
^newCollection!
upTo: anObject
"Answer a subcollection from the current access position to the
occurrence (if any, but not inclusive) of anObject in the receiver. If
anObject is not in the collection, answer the entire rest of the receiver."
| newStream element |
newStream _ WriteStream on: (collection species new: 100).
'A general mechanism to store preference choices. The default setup treats any symbol as a potential boolean flag; flags unknown to the preference dictionary are always returned as false. It is also possible to store non-boolean data in the preference table. sw 8/91'!
!Preferences class methodsFor: 'hard-coded prefs'!
startLoggingUserScripts
"Execute this to set the system to start logging user scripts to the changes log. 7/18/96 sw"
"Preferences startLoggingUserScripts"
Preferences class compile:
'logUserScripts
"Set to true if you want user scripts logged; later, we will maybe have a better way to specify this, or do something better altogether"
^ true' classified: 'logging'!
stopLoggingUserScripts
"Execute this to set the system to stop logging user scripts to the changes log. 7/18/96 sw"
"Preferences stopLoggingUserScripts"
Preferences class compile:
'logUserScripts
"Set to true if you want user scripts logged; later, we will maybe have a better way to specify this, or do something better altogether"
^ false' classified: 'logging'! !
!Preferences class methodsFor: 'general'!
chooseInitialSettings
"Set up the initial choices for Preferences. 2/7/96 sw
5/2/96 sw: added init for uniformWindowColors
5/22/96 sw: init reverseWindowStagger, clear out old window parms"
'I represent an independent path of control in the system. This path of control may be stopped (by sending the message suspend) in such a way that it can later be restarted (by sending the message resume). When any one of several paths of control can be advanced, the single instance of ProcessorScheduler named Processor determines which one will actually be advanced partly using the value of priority.'!
!Process methodsFor: 'changing process state'!
resume
"Primitive. Allow the process that the receiver represents to continue. Put
the receiver in line to become the activeProcess. Fail if the receiver is
already waiting in a queue (in a Semaphore or ProcessScheduler).
Essential. See Object documentation whatIsAPrimitive."
<primitive: 87>
self primitiveFailed!
suspend
"Primitive. Stop the process that the receiver represents in such a way
that it can be restarted at a later time (by sending the receiver the
message resume). If the receiver represents the activeProcess, suspend it.
Otherwise fail and the code below will remove the receiver from the list
of waiting processes. Essential. See Object documentation
whatIsAPrimitive."
<primitive: 88>
Processor activeProcess == self
ifTrue: [self primitiveFailed]
ifFalse:
[Processor remove: self ifAbsent: [self error: 'This process was not active'].
myList _ nil]!
terminate
"Stop the process that the receiver represents forever."
| context |
Processor activeProcess == self
ifTrue:
[thisContext sender == nil ifFalse:
[thisContext sender release].
thisContext removeSelf suspend]
ifFalse:
[myList == nil
ifFalse:
[myList remove: self ifAbsent: [].
myList _ nil].
context _ suspendedContext.
suspendedContext _ nil.
(context ~~ nil and: [context sender ~~ nil])
ifTrue: [context sender release]]! !
!Process methodsFor: 'changing suspended state'!
install: aContext
"Replace the suspendedContext with aContext."
self == Processor activeProcess
ifTrue: [^self error: 'The active process cannot install contexts'].
suspendedContext _ aContext!
popTo: aContext
"Replace the suspendedContext with aContext, releasing all contexts
between the currently suspendedContext and it."
self == Processor activeProcess
ifTrue: [^self error: 'The active process cannot pop contexts'].
suspendedContext releaseTo: aContext.
suspendedContext _ aContext! !
!Process methodsFor: 'accessing'!
offList
"Inform the receiver that it has been taken off a list that it was
suspended on. This is to break a backpointer."
myList _ nil!
priority
"Answer the priority of the receiver."
^priority!
priority: anInteger
"Set the receiver's priority to anInteger."
anInteger<=Processor highestPriority
ifTrue: [priority _ anInteger]
ifFalse: [self error: 'priority too high']!
suspendedContext
"Answer the context the receiver has suspended."
^suspendedContext!
suspendingList
"Answer the list on which the receiver has been suspended."
'Each screen is a manifestation of a project. Each project manages the scheduled views in it. While the user is working in the project, the changes made to classes are collected; a system-wide set of changes is the collection of all project changes. As a StringHolder, the string to be viewed is a description of the project.'!
!Project methodsFor: 'initialization'!
defaultBackgroundColor
^ #lightOrange!
initialExtent
^ (Display extent // 6) + (0@17)!
initialProject
self saveState.
projectHolder _ self!
setChangeSet: aChangeSet
projectChangeSet _ aChangeSet
!
setProjectHolder: aProject
projectWindows _ ControlManager new.
projectChangeSet _ ChangeSet new initialize.
projectTranscript _ TextCollector new.
displayDepth _ Display depth.
projectHolder _ aProject! !
!Project methodsFor: 'accessing'!
isTopProject
"Return true only of this is the top project (its own holder)"
^ projectHolder == self!
name
^ projectChangeSet name!
projectChangeSet
^ projectChangeSet!
views
| sc |
sc _ projectWindows screenController.
^ projectWindows scheduledControllers
select: [:c | c ~~ sc]
thenCollect: [:c | c view]! !
!Project methodsFor: 'menu messages'!
enter
"The user has chosen to change the context of the workspace to be that of
the receiver. Change the ChangeSet, Transcript, and collection of
!RealEstateAgent class methodsFor: 'as yet unclassified'!
initialFrameFor: aView
"Find a plausible initial screen area for the supplied view, which should be a StandardSystemView, taking into account the 'reverseWindowStagger' Preference, the size needed, and other windows currently on the screen. 5/22/96 sw"
"Initialize the class variables in the receiver. 5/22/96 sw"
"RealEstateAgent initialize"
StaggerOffset _ 6 @ 20.
ReverseStaggerOffset _ -6 @ 20.
StaggerOrigin _ 200 @ 30.
ScrollBarSetback _ 44.
ScreenTopSetback _ 18!
standardPositions
"Return a list of standard window positions -- this may have one, two, or four of them, depending on the size and shape of the display screen. 5/22/96 sw"
"Answer how many separate vertical columns of windows are wanted. 5/22/96 sw"
^ Preferences reverseWindowStagger
ifTrue:
[1]
ifFalse:
[(Display usableArea width > 640)
ifTrue:
[2]
ifFalse:
[1]]!
windowRowsDesired
"Answer how many separate horizontal rows of windows are wanted. 5/22/96 sw"
^ Preferences reverseWindowStagger
ifTrue:
[1]
ifFalse:
[(Display usableArea height > 480)
ifTrue:
[2]
ifFalse:
[1]]! !
RealEstateAgent initialize!
Object subclass: #Rectangle
instanceVariableNames: 'origin corner '
classVariableNames: ''
poolDictionaries: ''
category: 'Graphics-Primitives'!
Rectangle comment:
'I represent a rectangular area of the screen. Arithmetic functions take points as arguments and carry out scaling and translating operations to create new instances of me. Rectangle functions create new instances by determining intersections of rectangles with rectangles.'!
!Rectangle methodsFor: 'accessing'!
area
"Answer the receiver's area, the product of width and height."
| w |
(w _ self width) < 0 ifTrue: [^ 0].
^ w * self height max: 0!
bottom
"Answer the position of the receiver's bottom horizontal line."
^corner y!
bottom: anInteger
"Set the position of the bottom horizontal line of the receiver."
corner y: anInteger!
bottomCenter
"Answer the point at the center of the bottom horizontal line of the
receiver."
^self center x @ self bottom!
bottomLeft
"Answer the point at the left edge of the bottom horizontal line of the
receiver."
^origin x @ corner y!
bottomLeft: aPoint
"Set the point at the left edge of the bottom horizontal line of the
receiver."
origin x: aPoint x.
corner y: aPoint y.!
bottomRight
"Answer the point at the right edge of the bottom horizontal line of the
receiver."
^corner!
bottomRight: bottomRightPoint
"Set the position of the right corner of the bottom horizontal line of the
receiver."
corner _ bottomRightPoint!
boundingBox
^ self!
center
"Answer the point at the center of the receiver."
^self topLeft + self bottomRight // 2!
center: aPoint
"Set the point at the center of the receiver. Leave extent the same."
self moveBy: (aPoint - self center)!
corner
"Answer the point at the bottom right corner of the receiver."
^corner!
corner: cornerPoint
"Set the point at the bottom right corner of the receiver."
corner _ cornerPoint!
corners
"Return an array of corner points in the order of a quadrilateral spec for WarpBlt"
"Answer a Rectangle whose origin and corner are truncated to grid x and grid y."
^Rectangle origin: (origin truncateTo: grid)
corner: (corner truncateTo: grid)! !
!Rectangle methodsFor: 'transforming'!
align: aPoint1 with: aPoint2
"Answer a Rectangle that is a translated by aPoint2 - aPoint1."
^self translateBy: aPoint2 - aPoint1!
asQuad
"Return an array of corner points in the order of a quadrilateral spec for WarpBlt. Note that this is inset by 1 pixel from 'corners', as each point must be an actual pixel location."
"PRIVATE -- We just read externalObject. Give it a chance to internalize. Return the internalized object.
If become: is expensive, we could use it less often. It's needed when we've already given out references to the object being read (while recursively reading its contents). In other cases, we could just change the entry in the objects Dictionary.
If an object is pointed at from inside itself, then it cannot have a different external and internal form. It cannot be a PathFromHome or return anything other than self when sent comeFullyUpOnReload. (DiskProxy is OK)
Objects that do return something other than self when sent comeFullyUpOnReload must not point to themselves, even indirectly. 8/14/96 tk"
"Write it out, read it back, and return it for inspection."
^ self testWith: input
!
fileTypeCode
"Answer a default file type code to use for DataStream files. -- 11/13/92 jhm"
^ 'RefS'!
refTypes: oc
RefTypes _ oc!
versionCode
"Answer a number representing the 'version' of the ReferenceStream facility; this is stashed at the beginning of ReferenceStreams, as a secondary versioning mechanism (the primary one is the fileTypeCode). At present, it serves for information only, and is not checked for compatibility at reload time, but could in future be used to branch to variant code. 12/2/92 sw"
" 1 = "
" 2 = HyperSqueak. PathFromHome used for Objs outside the tree. SqueakSupport SysLibrary for shared globals like Display and StrikeFonts. File has version number, class structure, then an IncomingObjects manager. 8/16/96 tk"
'My instances provide space-efficient storage of data which tends to be constant over long runs of the possible indices. Essentially repeated values are stored singly and then associated with a "run" that denotes the number of consecutive occurrences of the value.
The variables lastIndex, lastRun and lastOffset cache the last access
so that streaming through RunArrays is not an N-squared process.'!
!RunArray methodsFor: 'accessing'!
at: index
| run offset value |
self at: index setRunOffsetAndValue: [:run :offset :value | ^value]!
runLengthAt: index
"Answer the length remaining in run beginning at index."
'I scan a string or text, picking out Smalltalk syntactic tokens. I look one character ahead. I put each token found into the instance variable, token, and its type (a Symbol) into the variable, tokenType. At the end of the input stream, I pretend to see an endless sequence of special characters called doits.'!
!Scanner methodsFor: 'initialize-release'!
initScanner
buffer _ WriteStream on: (String new: 40).
typeTable _ TypeTable!
scan: inputStream
"Bind the input stream, fill the character buffers and first token buffer."
source _ inputStream.
self step.
self step.
self scanToken! !
!Scanner methodsFor: 'public access'!
scanFieldNames: stringOrArray
"Answer an Array of Strings that are the identifiers in the input string,
stringOrArray. If passed an Array, just answer with that Array, i.e.,
assume it has already been scanned."
| strm |
(stringOrArray isMemberOf: Array)
ifTrue: [^stringOrArray].
self scan: (ReadStream on: stringOrArray asString).
strm _ WriteStream on: (Array new: 10).
[tokenType = #doIt]
whileFalse:
[tokenType = #word ifTrue: [strm nextPut: token].
self scanToken].
^strm contents
"Scanner new scanFieldNames: 'abc def ghi' ('abc' 'def' 'ghi' )"!
scanStringStruct: textOrString
"The input is a string whose elements are identifiers and parenthesized
groups of identifiers. Answer an array reflecting that structure, representing
each identifier by an uninterned string."
self scan: (ReadStream on: textOrString asString).
self scanStringStruct.
^token
"Scanner new scanStringStruct: 'a b (c d) (e f g)'"!
scanTokens: textOrString
"Answer an Array that has been tokenized as though the input text,
textOrString, had appeared between the array delimitors #( and ) in a
Smalltalk literal expression."
self scan: (ReadStream on: textOrString asString).
self scanLitVec.
^token
"Scanner new scanTokens: 'identifier keyword: 8r31 ''string'' .'"! !
!Scanner methodsFor: 'expression types'!
advance
| prevToken |
prevToken _ token.
self scanToken.
^prevToken!
nextLiteral
"Same as advance, but -4 comes back as a number instead of two tokens"
'I am the controller for the parts of the display screen that have no view on them. I only provide a standard yellow button menu. I view (a FormView of) an infinite gray form.'!
"Dan -- I tried a couple of things in an attempt to find a wholesale way to close all windows that didn't have unsubmitted changes them -- the idea is that sometimes one gets a screen full of dozens of windows from some furious investigation, and wants just to see the last of most of them. The code below appeared to do the right thing except that in the end the old windows stayed around as garbage, and I dropped this effort before figuring out what I'm doing wrong. 2/5/96 sw"
"Put up a list of windows with unaccepted input, and let the user chose one to activate. 1/18/96 sw. 2/22/96 sw: use hasUnacceptedInput"
ScheduledControllers findWindowSatisfying:
[:contr | contr model hasUnacceptedInput]!
modelUnchanged
"Answer true if the receiver's model is unchanged, and hence able to be closed. For the ScreenController, vacuously, we return false, so that no attempt is made to close the poor fellow. 2/5/96 sw"
^ false!
openBrowser
"Create and schedule a Browser view for browsing code."
BrowserView openBrowser!
openChangeManager
"Open a dual change sorter. For looking at two change sets at once."
DualChangeSorter new open!
openCommandKeyHelp
"1/18/96 sw Open a window that explains command-keys"
Utilities openCommandKeyHelp!
openFileList
"Create and schedule a FileList view for specifying files to access."
FileList open!
openProject
"Create and schedule a Project."
ProjectView open: Project new!
openStandardWorkspace
"Open a standard, throwaway window chock full of useful expressions. 1/17/96 sw"
Utilities openStandardWorkspace!
openSystemWorkspace
StringHolderView openSystemWorkspace!
openTranscript
"Create and schedule a System Transcript.
2/5/96 sw: if there is already one open, then instead of refusing the user permission, just activate the damned thing."
!ScreenController class methodsFor: 'class initialization'!
initialize
"Initialize the screen menus. Call this method to reset everything back to nil, so that the various menu retrieval methods will duly reinitialize them. 7/24/96 sw"
"Install the variant of the screen menu preferred by Scott. To restore the standard version, just set the TopScreenMenu class variable back to nil, or call ScreenController revertToStandardMenus, which does just that. 7/24/96 sw"
'I represent control for scrolling using a scrollBar. I am a MouseMenuController that creates a scrollBar, rather than menus. My subclasses add the button menus. I keep control as long as the cursor is inside the view or the scrollBar area.
A scrollBar is a rectangular area representing the length of the information being viewed. It contains an inner rectangle whose top y-coordinate represents the relative position of the information visible on the screen with respect to all of the information, and whose size represents the relative amount of that information visible on the screen. The user controls which part of the information is visible by pressing the red button. If the cursor is to the right of the inner rectangle, the window onto the visible information moves upward, if the cursor is to the left, the window moves downward, and if the cursor is inside, the inner rectangle is grabbed and moved to a desired position.'!
'I provide synchronized communication of a single bit of information (a "signal") between Processes. A signal is sent by sending the message signal and received by sending the message wait. If no signal has been sent when a wait message is sent, the sending Process will be suspended until a signal is sent.'!
!Semaphore methodsFor: 'initialize-release'!
initSignals
"Consume any excess signals the receiver may have accumulated."
excessSignals _ 0.!
terminateProcess
"Terminate the process waiting on this semaphore, if any."
'I am an abstract superclass for collections that have a well-defined order associated with their elements. Thus each element is externally-named by integers referred to as indices.'!
!SequenceableCollection methodsFor: 'comparing'!
= otherCollection
"Answer whether the species of the receiver is the same as
otherCollection's species, and the receiver's size is the same as
otherCollection's size, and each of the receiver's elements equal the
"Answer the element at my position index. If I do not contain an element
at index, answer the result of evaluating the argument, exceptionBlock."
(index between: 1 and: self size) ifTrue:
[^self at: index].
^exceptionBlock value!
atAll: anInterval put: anObject
"Put anObject at every index specified by the integer elements of
anInterval."
anInterval do: [:index | self at: index put: anObject]!
atAllPut: anObject
"Put anObject at every one of the receiver's indices."
1 to: self size do:
[:index | self at: index put: anObject]!
atRandom
"Return a random element of myself. Uses a shared random number generator owned by class Collection. If you use this a lot, define your own instance of Random and use atRandom:. Causes an error if self has no elements."
| index |
index _ (RandomForPicking next * self size) asInteger + 1.
^ self at: index
" #('one' 'or' 'the' 'other') atRandom
(1 to: 10) atRandom
'Just pick one of these letters at random' atRandom
"!
atRandom: aGenerator
"Return a random element of myself. Uses the instance of class Random supplied by the caller. Caller should keep the generator in a variable and use the same one every time. Use this instead of atRandom for better uniformity of random numbers because only you use the generator. Causes an error if self has no elements."
| index |
index _ (aGenerator next * self size) asInteger + 1.
^ self at: index
" | aGen |
aGen _ Random new.
(1 to: 10) atRandom: aGen
"!
first
"Answer the first element of the receiver. Create an error notification if
the receiver contains no elements."
self emptyCheck.
^self at: 1!
indexOf: anElement
"Answer the index of anElement within the receiver. If the receiver does
not contain anElement, answer 0."
^self indexOf: anElement ifAbsent: [0]!
indexOf: anElement ifAbsent: exceptionBlock
"Answer the index of anElement within the receiver. If the receiver does
not contain anElement, answer the result of evaluating the argument,
"Force the length of the collection to length, padding if necissary
with elem. Note that this makes a copy."
| newCollection copyLen |
newCollection _ self species new: length.
copyLen _ self size.
1 to: length do: [ :index |
(index <= copyLen) ifTrue: [
newCollection at: index put: (self at: index) ]
ifFalse: [
newCollection at: index put: elem ] ].
^ newCollection!
shallowCopy
^self copyFrom: 1 to: self size!
shuffled
| copy random max | "($A to: $Z) shuffled"
copy _ self shallowCopy.
random _ Random new.
max _ self size.
1 to: max do: [:i | copy swap: i with: (random next * max) asInteger + 1].
^ copy!
sortBy: aBlock
"Create a copy that is sorted. Sort criteria is the block that accepts two arguments. When the block is true, the first arg goes first ([:a :b | a > b] sorts in descending order)."
"Answer an Array whose elements are the elements of the receiver, in
the same order."
| newArray |
newArray _ Array new: self size.
1 to: self size do: [:index | newArray at: index put: (self at: index)].
^newArray!
asDictionary
"Answer a Dictionary whose keys are string versions of my indices and whose values are my elements. 6/12/96 sw"
| aDictionary |
aDictionary _ Dictionary new.
1 to: self size do:
[:i | aDictionary add:
(Association key: i printString value: (self at: i))].
^ aDictionary!
asSortedArray
1 to: (self size - 1) do:
[:i | (self at: i) >= (self at: (i+1)) ifTrue:
[self flag: #developmentNote.
"The optimization used here is, I HOPE, really an optimization. The idea is that most collections processed will already be sorted, so we don't bother going through the double-transformation of the next line until we're sure that it is necessary. On the other hand, the test for need-to-sort is itself not free. sw"
^ self asSortedCollection asArray]].
^ self asArray!
asStringWithCr
"Convert to a string with returns between items. Elements are usually strings.
Useful for labels for PopUpMenus."
| labelStream |
labelStream _ WriteStream on: (String new: 200).
self do: [:each |
(each isKindOf: String)
ifTrue: [labelStream nextPutAll: each; cr]
ifFalse: [each printOn: labelStream; cr]].
self size > 0 ifTrue: [labelStream skip: -1].
^ labelStream contents!
mappedBy: aSequenceableCollection
"Answer a MappedCollection whose contents is the receiver and whose
"Answer the index of a first slot containing either a nil (indicating an empty slot) or an element that matches the given object. Answer the index of that slot or zero. Fail if neither a match nor an empty slot is found."
| start index length |
"search from (hash mod size) to the end"
length _ array size.
start _ (anObject hash \\ length) + 1.
index _ self scanFor: anObject from: start to: length.
index > 0 ifTrue: [ ^ index ].
"search from 1 to where we started"
index _ self scanFor: anObject from: 1 to: start - 1.
index > 0 ifTrue: [ ^ index ].
"Bad scene. Neither have we found a matching element
nor even an empty slot. No hashed set is ever supposed to get
completely full."
self error: 'There is no free space in this set!!'.!
fixCollisionsFrom: index
"The element at index has been removed and replaced by nil.
This method moves forward from there, relocating any entries
that had been placed below due to collisions with this one"
"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches the key. Answer the index of that slot or zero if no slot is found within the given range of indices. This method will be overridden in various subclasses that have different models for finding a matching element."
| element |
"this speeds up a common case: key is in the first slot"
'I provide synchronized communication of arbitrary objects between Processes. An object is sent by sending the message nextPut: and received by sending the message next. If no object has been sent when a next message is sent, the Process requesting the object will be suspended until one is sent.'!
!SharedQueue methodsFor: 'initialize-release'!
release
"Refer to the comment in Object|release."
contentsArray _ nil! !
!SharedQueue methodsFor: 'accessing'!
next
"Answer the object that was sent through the receiver first and has not
yet been received by anyone. If no object has been sent, suspend the
requesting process until one is."
| value |
readSynch wait.
accessProtect
critical: [readPosition = writePosition
ifTrue:
[self error: 'Error in SharedQueue synchronization'.
value _ nil]
ifFalse:
[value _ contentsArray at: readPosition.
contentsArray at: readPosition put: nil.
readPosition _ readPosition + 1]].
^value!
nextPut: value
"Send value through the receiver. If a Process has been suspended
waiting to receive a value through the receiver, allow it to proceed."
accessProtect
critical: [writePosition > contentsArray size
ifTrue: [self makeRoomAtEnd].
contentsArray at: writePosition put: value.
writePosition _ writePosition + 1].
readSynch signal.
^value!
peek
"Answer the object that was sent through the receiver first and has not
yet been received by anyone but do not remove it from the receiver. If
no object has been sent, suspend the requesting process until one is."
!SharedQueue class methodsFor: 'instance creation'!
new
"Answer a new instance of SharedQueue that has 10 elements."
^self new: 10!
new: anInteger
^super new init: anInteger! !Integer subclass: #SmallInteger
instanceVariableNames: ''
classVariableNames: 'Digitbuffer '
poolDictionaries: ''
category: 'Numeric-Numbers'!
SmallInteger comment:
'My instances are 15 or 16-bit numbers, stored in twos complement form. The allowable range is from -16384 to 16383. You can type an instance of me in octal representation by typing a leading radix specification, such as in 8r377.'!
!SmallInteger methodsFor: 'arithmetic'!
* aNumber
"Primitive. Multiply the receiver by the argument and answer with the
result if it is a SmallInteger. Fail if the argument or the result is not a
SmallInteger. Essential. No Lookup. See Object documentation
whatIsAPrimitive."
<primitive: 9>
self = 0 ifTrue: [^0].
"This eliminates the need for a self=0 check in LargeInteger *"
^super * aNumber!
+ aNumber
"Primitive. Add the receiver to the argument and answer with the result
if it is a SmallInteger. Fail if the argument or the result is not a
SmallInteger Essential No Lookup. See Object documentation
whatIsAPrimitive."
<primitive: 1>
^super + aNumber!
- aNumber
"Primitive. Subtract the argument from the receiver and answer with the
result if it is a SmallInteger. Fail if the argument or the result is not a
SmallInteger. Essential. No Lookup. See Object documentation
whatIsAPrimitive."
<primitive: 2>
^super - aNumber!
/ aNumber
"Primitive. This primitive (for /) divides the receiver by the argument
and returns the result if the division is exact. Fail if the result is not a
whole integer. Fail if the argument is 0 or is not a SmallInteger. Optional.
No Lookup. See Object documentation whatIsAPrimitive."
<primitive: 10>
aNumber = 0 ifTrue: [^self error: 'division by 0'].
"Return the number of 32-bit sound samples that fit in this sound buffer. For stereo, 16-bit left and right channel samples are packed into each 32-bit word. For mono, samples are still 32-bits, but only the low-order 16 bits of each sample are played."
^ super size!
size
"Return the number of 16-bit sound samples that fit in this sound buffer."
^ super size * 2! !
!SoundBuffer methodsFor: 'primitives'!
at: index
<primitive: 143>
index isInteger ifTrue: [ self errorSubscriptBounds: index ].
index isNumber ifTrue: [ ^ self at: index truncated ].
self errorNonIntegerIndex.!
at: index put: value
<primitive: 144>
index isInteger ifTrue: [
(index >= 1 and: [index <= self size])
ifTrue: [ self errorImproperStore ]
ifFalse: [ self errorSubscriptBounds: index ].
].
index isNumber ifTrue: [ ^ self at: index truncated put: value ].
self errorNonIntegerIndex.
!
primFill: aPositiveInteger
"Fill the receiver, an indexable bytes or words object, with the given positive integer. The range of possible fill values is [0..255] for byte arrays and [0..(2^32 - 1)] for word arrays."
'Provides a simple, platform-independent, interface to a file system. This initial version ignores issues of Directories etc. The instance-variable fallbackStream at the moment holds an instance of HFSMacFileStream, to bridge us to the new world while in the old. The instance variable rwmode, inherited from class PositionableStream, here is used to hold a Boolean -- true means opened for read-write, false means opened for read-only. 2/12/96 sw'!
!StandardFileStream methodsFor: 'open/close'!
close
"Close the receiver. 12/12/96 sw"
self primClose: fileID.
closed _ true!
open
"For compatibility with a few existing things. 2/14/96 sw"
^ self reopen!
open: aFileName forWrite: writeMode
"Open the receiver. If writeMode is true, allow write, else access will be read-only. 2/12/96 sw"
crLf _ String with: Character cr with: (Character value: 10).
s _ ReadStream on: (self next: self size).
self close.
f _ FileStream newFileNamed: self name.
[s atEnd] whileFalse:
[f nextPutAll: (s upTo: Character cr); nextPutAll: crLf].
f close!
isBinary
^ buffer1 class == ByteArray!
readOnly
"Set the receiver to be read-only"
rwmode _ false!
setType: tString creator: cString
"Mac-specific; set the type and creator of the corresponding file; for the moment, we only define this where we have the backward-compatible implementation via fallback stream. Ultimately, for this to work, some new primitive will need to be added to StandardFileStream. 2/14/96 sw"
!
writing
"Answer whether the receiver is in the process of writing. Probably obsolete -- only sender outside of HFS-specific code is in FileStream>>close, which is, in effect, abstract, and not actually reached now. I THINK. 2/12/96 sw"
^ rwmode! !
!StandardFileStream methodsFor: 'access'!
file
"Answer the object representing the receiver's file. Need for compatibility with some calls -- check senders. 2/14/96 sw"
^ self!
fileID
"Return the fileID that was handed returned by the file-opening primitive. This id needs to be handed on to the other file-related primitives. 2/12/96 sw"
^ fileID!
fullName
^ name!
isDirectory
"Answer whether the receiver represents a directory. For the post-transition case, uncertain what to do. 2/14/96 sw"
^ false!
name
"Answer the receiver's name, which is the same as the formal filename on disk. 1/31/96 sw"
^ name!
peekFor: item
"Answer false and do not move over the next element if it is not equal to
the argument, anObject, or if the receiver is at the end. Answer true
and increment the position for accessing elements, if the next element is
equal to anObject.. Copied over from HFS versino. 2/14/96 sw"
| next |
self atEnd ifTrue: [^ false].
next _ self next.
item = next ifTrue: [^ true].
self skip: -1.
^ false!
printOn: aStream
"Put a printed version of the receiver onto aStream. 1/31/96 sw"
aStream nextPutAll: self class name; nextPutAll: ': '; print: name!
reset
^ self reopen!
size
"Answer the size of the file in characters. 2/12/96 sw"
"Set the position of the receiver to the end of file. 1/31/96 sw"
self position: self size!
skip: n
"Set the character position to n characters from the current position.
Error if not enough characters left in the file. 1/31/96 sw"
self position: self position + n!
upTo: delim
"Fast version to speed up nextChunk"
| pos buffer count |
pos _ self position.
buffer _ self next: 2000.
(count _ buffer indexOf: delim) > 0 ifTrue:
["Found the delimiter part way into buffer"
self position: pos + count.
^ buffer copyFrom: 1 to: count - 1].
self atEnd ifTrue:
["Never found it, and hit end of file"
^ buffer].
"Never found it, but there's more..."
^ buffer , (self upTo: delim)! !
!StandardFileStream methodsFor: 'primitives'!
primAtEnd: id
"Answer whether the receiver is currently at its end. 2/12/96 sw"
<primitive: 150>
^ self primitiveFailed!
primClose: anID
"Primitive call to close the receiver. 2/12/96 sw"
<primitive: 151>
^ self primitiveFailed!
primGetPosition: id
"Get the receiver's current file position. 2/12/96 sw"
<primitive: 152>
^ self primitiveFailed!
primOpen: fileName writable: aBoolean
"Open a file of the given name, and return the file id obtained.
If writable is true, then
if there is none with this name, then create one
else prepare to overwrite from the beginning
otherwise open readonly,
or return nil if there is no file with this name"
<primitive: 153>
^ nil!
primRead: id into: byteArray startingAt: startIndex count: count
"read from the receiver's file into the given area of storage, starting at the given index, as many as count bytes; return the number of bytes actually read. 2/12/96 sw"
<primitive: 154>
self halt: 'error reading file'!
primSetPosition: id to: aNumber
"Set the receiver's file position to be a Number. 2/12/96 sw"
<primitive: 155>
^ self primitiveFailed!
primSize: id
"Return the size of the receiver's file. 2/12/96 sw"
<primitive: 157>
^ self primitiveFailed!
primWrite: id from: byteArray startingAt: startIndex count: count
"Write into the receiver's file from the given area of storage, starting at the given index, as many as count bytes; return the number of bytes actually written. 2/12/96 sw"
<primitive: 158>
closed ifTrue: [^ self halt: 'Write error: File not open'].
rwmode ifFalse: [^ self halt: 'Error-attempt to write to a read-only file.'].
!StandardFileStream class methodsFor: 'file creation'!
fileNamed: aFileName
"Open a file in the default directory (or in the directory contained
in the input arg); by default, it's available for writing. 2/12/96 sw
Prior contents will be overwritten, but not truncated on close. 3/18 di"
^ self new open: aFileName forWrite: true!
isAFileNamed: fName
| f |
f _ self new open: fName forWrite: false.
f == nil ifTrue: [^ false].
f close.
^ true!
newFileNamed: aFileName
"create a file in the default directory (or in the directory contained in the input arg), set for write access. 2/12/96 sw. Fixed 6/13/96 sw so that if deletion of old conflicting file fails, the error raised is more helpful."
'I am a controller for StandardSystemViews, that is, those views that are at the top level of a project in the system user interface. I am a kind of MouseMenuController that creates a blue button menu for moving, framing, collapsing, and closing ScheduledViews, and for selecting views under the view of my instance.'!
!StandardSystemController class methodsFor: 'class initialization'!
initialize
"Set up the menus for standard windows.
6/6/96 sw: added fullScreen"
self flag: #noteToDan. "
1. note that I added a fullScreen command.
2. the old macPaint command appears to be broken. We should presumably fix it or discard it.
3. the frame command seems no longer to allow you to reframe an open window, and of course its functionality has now been overtaken by the drag-corners stuff.
4. move and label and collapse and close are all redundant with title-bar controls.
With the above in mind, I've for the moment removed macPaint and frame, but kept the four redundant commands to use in those cases where owing to some bug you can't see a window's title bar.
'I represent a view that has a label above its top left corner. The text in the label identifies the kind of view. In addition to a label, I add control over the maximum and minimum size of the display box of my instance. My default controller is StandardSystemController. The elements of ScheduledControllers, the sole instance of ControlManager, are usually controllers for instances of me.'!
insetDisplayBox == nil ifTrue: [^ self]. "wait for further initialization"
self setLabelRegion]!
labelColor
"Answer the color to use as the background for the receiver's label. By default, this is the same as the background color of the window, but need not be. 7/16/96 sw"
^ self backgroundColor!
labelDisplayBox
"Answer the rectangle that borders the visible parts of the receiver's label
on the display screen."
^ labelFrame region
align: (self isCollapsed
ifTrue: [labelFrame topLeft]
ifFalse: [labelFrame bottomLeft])
with: self displayBox topLeft!
labelTextRegion
| topLeft |
labelText == nil ifTrue: [^ self labelDisplayBox center extent: 0@0].
"Answer the desired extent for the receiver when it is first opened on the screen. 1/22/96 sw"
^ model initialExtent!
initialFrame
"Find a plausible initial screen area for the receiver, taking into account user preference, the size needed, and other windows currently on the screen. 5/22/96 sw: let RealEstateAgent do it for us"
^ RealEstateAgent initialFrameFor: self!
moved
"The user has moved the receiver; after a new view rectangle is chosen, this method is called to allow certain views to take note of the change. 6/10/96 sw" !
self error: 'Streams are created with on: and with:'! !Object subclass: #StrikeFont
instanceVariableNames: 'xTable glyphs name stopConditions type minAscii maxAscii maxWidth strikeLength ascent descent xOffset raster subscript superscript emphasis '
classVariableNames: ''
poolDictionaries: 'TextConstants '
category: 'Graphics-Support'!
StrikeFont comment:
'I represent a compact encoding of a set of Forms corresponding to characters in the ASCII character set. All the forms are placed side by side in a large form whose height is the font height, and whose width is the sum of all the character widths. The xTable variable gives the left-x coordinates of the subforms corresponding to the characters.'!
!StrikeFont methodsFor: 'accessing'!
ascent
"Answer the receiver's maximum extent of characters above the baseline."
^ascent!
characterFormAt: character
"Answer a Form copied out of the glyphs for the argument, character."
| ascii leftX rightX characterForm |
ascii _ character asciiValue.
leftX _ xTable at: ascii + 1.
rightX _ xTable at: ascii + 2.
characterForm _ Form extent: (rightX-leftX) @ self height.
characterForm copy: characterForm boundingBox
from: leftX@0 in: glyphs rule: Form over.
^ characterForm!
characterFormAt: character put: characterForm
"Copy characterForm over the glyph for the argument, character."
'I am an indexed collection of Characters. I really store 8-bit bytes, but my access protocol translates between these and real Character instances.'!
!String methodsFor: 'accessing'!
at: index
"Primitive. Answer the Character stored in the field of the receiver
indexed by the argument. Fail if the index argument is not an Integer or
is out of bounds. Essential. See Object documentation whatIsAPrimitive."
<primitive: 63>
^Character value: (super at: index)!
at: index put: aCharacter
"Primitive. Store the Character in the field of the receiver indicated by
the index. Fail if the index is not an Integer or is out of bounds, or if
the argument is not a Character. Essential. See Object documentation
whatIsAPrimitive."
<primitive: 64>
(aCharacter isKindOf: Character)
ifTrue: [self errorNonIntegerIndex]
ifFalse: [self error: 'Strings only store Characters']!
endsWithDigit
"Answer whether the receiver's final character represents a digit. 3/11/96 sw"
^ self size > 0 and: [self last isDigit]!
findDelimiters: delimiters startingAt: start
"Answer the index of the character within the receiver, starting at start, that matches one of the delimiters. If the receiver does not contain any of the delimiters, answer size + 1."
"Primitive. Answer the number of indexable fields in the receiver. This
value is the same as the largest legal subscript. Essential. See Object
documentation whatIsAPrimitive."
<primitive: 62>
^self basicSize!
skipDelimiters: delimiters startingAt: start
"Answer the index of the character within the receiver, starting at start, that matches one of the delimiters. If the receiver does not contain any of the delimiters, answer size + 1. Assumes the delimiters to be a non-empty string."
"Answer a Paragraph whose text string is the receiver."
^Paragraph withText: self asText!
asString
"Answer the receiver itself."
^self!
asSymbol
"Answer the unique Symbol whose characters are the characters of the
string."
^Symbol intern: self!
asText
"Answer a Text whose string is the receiver."
^Text fromString: self!
asUnHtml
"Strip out all Html stuff (commands in angle brackets <>) and convert the characters &<> back to their real value. Leave actual cr and tab as they were in text. 4/12/96 tk"
| in out char rest did |
in _ ReadStream on: self.
out _ WriteStream on: (String new: self size).
[in atEnd] whileFalse: [
in peek = $< ifTrue: [in unCommand]. "Absorb <...><...>"
(char _ in next) = $&
ifTrue: [
rest _ in upTo: $;.
did _ out position.
rest = 'lt' ifTrue: [out nextPut: $<].
rest = 'gt' ifTrue: [out nextPut: $>].
rest = 'amp' ifTrue: [out nextPut: $&].
did = out position ifTrue: [
self error: 'new HTML char encoding'.
"Please add it to this code"]]
ifFalse: [out nextPut: char].
].
^ out contents!
asUppercase
"Answer a String made up from the receiver whose characters are all
uppercase."
| aStream |
aStream _ WriteStream on: (String new: self size).
"return myself or a copy shortened by ellipsis to smallSize"
| leftSize |
self size <= smallSize
ifTrue: [^ self]. "short enough"
smallSize < 5
ifTrue: [^ self copyFrom: 1 to: smallSize]. "First N characters"
leftSize _ smallSize-2//2.
^ self copyReplaceFrom: leftSize+1 "First N/2 ... last N/2"
to: self size - (smallSize - leftSize - 3)
with: '...'!
correctAgainst: wordList
"Correct the receiver: assume it is a misspelled word and return the (maximum of five) nearest words in the wordList. Depends on the scoring scheme of alike:"
"Return a copy of the receiver up to, but not including, the first period. If the receiver's *first* character is a period, then just return the entire receiver. "
| likely |
likely _ self copyUpTo: $..
^ likely size == 0
ifTrue: [self]
ifFalse: [likely]!
stemAndNumericSuffix
"Parse the receiver into a string-valued stem and a numeric-valued suffix. 6/7/96 sw"
[suffix _ stem last digitValue * position + suffix.
position _ position * 10.
stem _ stem copyFrom: 1 to: stem size - 1].
^ Array with: stem with: suffix
"'Fred2305' stemAndNumericSuffix"!
truncateTo: smallSize
"return myself or a copy shortened to smallSize. 1/18/96 sw"
^ self size <= smallSize
ifTrue:
[self]
ifFalse:
[self copyFrom: 1 to: smallSize]!
withBlanksTrimmed
"Return a copy of the receiver from which leading and trailing blanks have been trimmed. This is a quick-and-dirty, sledge-hammer implementation; improvements welcomed. 1/18/96 sw"
"Answer a string that represents the receiver. For most objects this is simply its printString, but for strings themselves, it's themselves, to avoid the superfluous extra pair of quotes. 6/12/96 sw"
replaceFrom: start to: stop with: replacement startingAt: repStart
"Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
<primitive: 105>
super replaceFrom: start to: stop with: replacement startingAt: repStart!
stringhash
^self hash! !
!String methodsFor: 'system primitives'!
numArgs
"Answer either the number of arguments that the receiver would take if considered a selector. Answer -1 if it couldn't be a selector. Note that currently this will answer -1 for anything begining with an uppercase letter even though the system will accept such symbols as selectors. It is intended mostly for the assistance of spelling correction."
"Answer an instance of me that is determined by reading the stream,
inStream. Embedded double quotes become the quote Character."
| outStream char done |
outStream _ WriteStream on: (String new: 16).
"go to first quote"
inStream skipTo: $'.
done _ false.
[done or: [inStream atEnd]]
whileFalse:
[char _ inStream next.
char = $'
ifTrue:
[char _ inStream next.
char = $'
ifTrue: [outStream nextPut: char]
ifFalse: [done _ true]]
ifFalse: [outStream nextPut: char]].
^outStream contents! !
!String class methodsFor: 'examples'!
example
"To see the string displayed at the cursor point, execute this expression
and select a point by pressing a mouse button."
'this is some text' displayOn: Display at: Sensor waitButton! !Model subclass: #StringHolder
instanceVariableNames: 'contents isLocked '
classVariableNames: 'Workspace '
poolDictionaries: ''
category: 'Interface-Support'!
StringHolder comment:
'I represent a layer of structure in order to view an aspect of a model that includes a string as part of its information.'!
!StringHolder methodsFor: 'initialize-release'!
defaultBackgroundColor
^ #lightYellow!
initialize
"Initialize the state of the receiver to be unlocked with default contents
(empty string)."
isLocked _ false.
contents _ self defaultContents! !
!StringHolder methodsFor: 'accessing'!
contents
"Answer the contents that the receiver is holding--presumably a string."
^contents!
contents: aString
"Set aString to be the contents of the receiver."
contents _ aString! !
!StringHolder methodsFor: 'code'!
doItContext
"Answer the context in which a text selection can be evaluated."
^nil!
doItReceiver
"Answer the object that should be informed of the result of evaluating a
text selection."
^nil! !
!StringHolder methodsFor: 'lock access'!
hasBeenChanged
"Answer whether the receiver, serving as a model for some window, has been changed, and hence should not be blithely discarded without warning. 2/5/96 sw"
^ self isUnlocked not!
isLocked
"Answer whether the receiver is locked, that is, has the contents of the
receiver been modified since the last time it was unlocked."
^isLocked!
isUnlocked
"Answer whether the receiver is unlocked."
^isLocked not!
lock
"Note that the receiver has been modified."
isLocked _ true!
okToChange
self isUnlocked ifTrue: [^ true].
self changed: #wantToChange. "Solicit cancel from view"
^ self isUnlocked!
unlock
"Unlock the receiver. Any modification has presumably been saved."
'I represent a ParagraphEditor for a single paragraph of text, omitting alignment commands. I provide items in the yellow button menu so that the text selection can be evaluated and so that the contents of the model can be stored or restored.
doIt evaluate the text selection as an expression
printIt same as doIt but insert a description of the result after the selection
accept store the contents of the StringHolder into the model
cancel store the contents of the model into the StringHolder'!
"Make a correction in the model that the user has authorised from somewhere else in the system (such as from the compilier). The user's selection is not changed, only corrected."
| wasShowing userSelection delta loc |
aString = '#insert period' ifTrue:
[loc _ start.
[(loc _ loc-1)>0 and: [(paragraph text string at: loc) isSeparator]]
!StringHolderController class methodsFor: 'class initialization'!
initialize
"Initialize the yellow button pop-up menu and corresponding messages.
1/12/96 sw: added senders of it, etc. 1/15/96 sw: explain
1/22/96 sw: cmd keys detailed
1/24/96 sw: added find; moved many items to shifted side etc.
1/26/96 sw: made compatible with paragraph editor's version; I'm not clear on when/how this guy gets used (seemingly eg in a workspace) vs when the paragraph editor's does (seemingly in browsers)
2/29/96 sw: correct cmd-key equivalent for do again, and add set-search-string"
CodeYellowButtonMenu _
PopUpMenu
labels:
'find...(f)
find again (g)
set search string (h)
do again (j)
undo (z)
copy (c)
cut (x)
paste (v)
do it (d)
print it (p)
inspect it (i)
accept (s)
cancel (l)
more...'
lines: #(3 5 8 11 13).
CodeYellowButtonMessages _
#(find findAgain setSearchString again undo copySelection cut paste doIt printIt inspectIt accept cancel shiftedYellowButtonActivity)
"StringHolderController initialize"! !
StringHolderController initialize!
View subclass: #StringHolderView
instanceVariableNames: 'displayContents '
classVariableNames: ''
poolDictionaries: ''
category: 'Interface-Support'!
StringHolderView comment:
'I am a View of a String that is an aspect of a more structured object. This String should not be changed by any editing unless the user issues the accept command. Thus my instances provide a working copy of the String. This copy is edited. When the user issues the accept command, the String is copied from the working version; or if the user issues the cancel command, the working version is restored from the String. StringHolderController is my default controller. It is initialized specially by passing the string viewed which is then converted to a Paragraph for editing.'!
'I represent a selection setting and actions to take depending on a change in the setting. An instance has three attributes: state, which is either on or off; on action; and off action. The on and off actions are blocks of code that execute whenever the instance changes state. I am typically used as a menu item in conjunction with a SwitchView and a SwitchController.
1/24/96 sw: made this a subclass of Model, for faster dependents handling'!
!Switch methodsFor: 'initialize-release'!
release
"Set the on and off actions of the receiver to nil ('no action') in order to
break possible pointer cycles. It is sent by Switch|deleteDependent: when
the last dependent has been deleted from the Switch's list of dependents."
super release.
onAction _ nil.
offAction _ nil! !
!Switch methodsFor: 'dependents access'!
removeDependent: aDependent
"If aDependent is the only dependent in the list, the receiver sends
Switch|release to try to break up possible pointer cycles."
super removeDependent: aDependent.
self dependents isEmpty ifTrue: [self release]! !
!Switch methodsFor: 'clearing'!
clear
"Set the state of the receiver to 'off'. If the state of the receiver was
previously 'on', then 'self change' is sent. The receiver's off action is
NOT executed."
self isOn
ifTrue:
[on _ false.
self changed]! !
!Switch methodsFor: 'state'!
isOff
"Answer whether the receiver is set off or not."
^on not!
isOn
"Answer whether the receiver is set on or not."
^on!
set
"Set the state of the receiver to 'on'. If the state of the receiver was
previously 'off', then 'self change' is sent. The receiver's on action is
NOT executed."
self isOff
ifTrue:
[on _ true.
self changed]!
switch
"Change the state of the receiver from 'on' to 'off' or from 'off' to 'on' (see
Switch|turnOn, Switch|turnOff)."
self isOn
ifTrue: [self turnOff]
ifFalse: [self turnOn]!
turnOff
"Set the state of the receiver to 'off'. If the state of the receiver was
previously 'on', then 'self change' is sent and the receiver's off action is
executed."
self isOn
ifTrue:
[on _ false.
self changed.
self doAction: offAction]!
turnOn
"Set the state of the receiver to 'on'. If the state of the receiver was
previously 'off', then 'self change' is sent and the receiver's on action is
"Answer an instance of me such that the on and off actions are set to nil
('no action'), and the state is set to 'off'."
^self newOff!
newOff
"Answer an instance of me such that the on and off actions are set to nil
('no action'), and the state is set to 'off'."
^super new initializeOff!
newOn
"Answer an instance of me such that the on and off actions are set to nil
('no action'), and the state is set to 'on'."
^super new initializeOn! !Controller subclass: #SwitchController
instanceVariableNames: 'selector arguments '
classVariableNames: ''
poolDictionaries: ''
category: 'Interface-Menus'!
SwitchController comment:
'I coordinate the interaction of a Switch, a SwitchView, and input events (user actions, see class Sensor). My instances own a message in the form of a selector and an array of arguments. Whenever the Switch is selected, this message is sent to the Switch. I want control if the cursor is in the view and the red button is pressed.'!
'I am a view of a Switch. My instances have labels and display modes (set to "normal" or "complemented"). When one of my instances is displayed in complemented mode, its inside color is reversed. The value of the display mode corresponds to the value of the model so that, for example, when a Switch is off, its SwitchView is displayed with black text (for the label) on a white background, and when the Switch is on, its SwitchView is displayed with white text on a black background. My instances have a key character that can be used for selecting the model. Highlighting can be done specially using a stored form, rather than simply changing all black bits to white, and vice versa. My instances'' default controller is SwitchController.'!
!SwitchView methodsFor: 'initialize-release'!
initialize
"Refer to the comment in View|initialize."
super initialize.
complemented _ false.
label _ nil.
selector _ #isOn.
arguments _ #()!
release
super release.
label release! !
!SwitchView methodsFor: 'accessing'!
arguments
"Answer the arguments the receiver sends in a message to its receiver."
^arguments!
arguments: anArray
"The argument, anArray, consists of the arguments of the message
the receiver sends to its model."
arguments _ anArray!
highlightForm: aForm
"The argument is the form to be used to highlight the receiver."
highlightForm _ aForm!
key: aCharacter
"Set the receiver to be selected by the argument, aCharacter."
keyCharacter _ aCharacter! !
!SwitchView methodsFor: 'testing'!
containsKey: aCharacter
"Answer whether the receiver can be selected by the argument,
aCharacter."
^keyCharacter = aCharacter! !
!SwitchView methodsFor: 'controller access'!
defaultControllerClass
"Refer to the comment in View|defaultControllerClass."
^SwitchController! !
!SwitchView methodsFor: 'window access'!
defaultWindow
"Returns the frame of the SwitchView's label's frame (slightly enlarged)
if the label exists, and returns the standard View default window (see
View|defaultWindow), otherwise."
label == nil
ifTrue: [^super defaultWindow]
ifFalse: [^label boundingBox expandBy: 6]!
window: aWindow
"Refer to the comment in View|window:."
super window: aWindow.
self centerLabel! !
!SwitchView methodsFor: 'displaying'!
display
"Sets the SwitchView mode to 'normal', displays the border, displays the
inside and, if its model is 'on', complements the inside."
self displayBorder.
self displayView!
displayComplemented
"Complement the receiver if its mode is 'normal'."
complemented
ifFalse:
[complemented _ true.
self highlight]!
displayNormal
"Complement the receiver if its mode is 'complemented'."
complemented
ifTrue:
[complemented _ false.
self highlight]!
displaySpecial
"The receiver has a special highlight form. Use it for displaying
complemented, if appropriate."
complemented
ifTrue: [self displaySpecialComplemented].
label == nil
ifFalse: [label
displayOn: Display
transformation: self displayTransformation
clippingBox: self insetDisplayBox
align: label boundingBox center
with: label boundingBox center
rule: Form under
fillColor: nil]!
displaySpecialComplemented
"Display the receiver complemented using its special highlight form."
highlightForm
displayOn: Display
transformation: self displayTransformation
clippingBox: self insetDisplayBox
fixedPoint: label boundingBox center!
displayView
"Does the standard View actions and, in addition, displays the receiver's
label based on the current display transformation and inset display box."
"Answer a list of selectors that contain aString within them. Case-insensitive.
1/15/96 sw. This is an extremely slow, sledge-hammer approach at present, taking around 30 seconds to execute on an FX. A variety of speedups is conceivable -- improvements invited."
'I represent a report of a syntax error when reading class descriptions from a noninteractive source such as an external file. As a StringHolder, the string to be viewed is the code or expression containing the error.'!
!SyntaxError methodsFor: 'menu messages'!
proceed: aController
"The error has presumably been fixed and the file in that created the
syntax error can now be continued."
| d |
d _ debugger. debugger _ nil. "break cycle"
d proceed: aController!
spawn: aString
"Create and schedule a message browser on the message, aString. Any
edits already made are retained."
self messageListIndex > 0
ifTrue:
[^BrowserView
openMessageBrowserForClass: class
selector: selector
editString: aString]! !
!SyntaxError methodsFor: 'message list'!
list
"Answer an array of one element made up of the class name, message
category, and message selector in which the syntax error was found.
This is the single item in the message list of a view/browser on the
receiver."
^Array with: class name , ' ' , category , ' ' , selector!
messageListIndex
"Answer the current selection (there is only one) of the receiver's list."
^selectionIndex! !
!SyntaxError methodsFor: 'class list'!
selectedClass
"Answer the class in which the syntax error occurred."
^class!
selectedClassOrMetaClass
"Answer the class in which the syntax error occurred."
^class! !
!SyntaxError methodsFor: 'selecting'!
selectionIndex
"Answer the current list selection."
^selectionIndex!
toggleIndex: anInteger
"Answer the receiver since only one item can be selected--thus
preventing deselection."
^self! !
!SyntaxError methodsFor: 'contents'!
category: aSymbol
"Set the category so it will be known when the user correct the error and accepts. TK 15 May 96"
category _ aSymbol!
contents: aString notifying: aController
"Compile the code in aString and notify aController of any errors. Answer
true if compilation succeeds, false otherwise."
| selectedMessageName compiledSelector |
selectedMessageName _ selector.
compiledSelector _ class
compile: aString
classified: category
notifying: aController.
compiledSelector == nil ifTrue: [^false].
contents _ aString.
^true!
notify: error at: location in: source
"Put up a SyntaxError window in the normal way. And we know the category. TK 15 May 96."
"Open a standard system view whose model is an instance of me. The syntax error occurred in typing to add code, aString, to class, aClass. "
'I am a kind of LockedListController that creates a yellow button menu for proceeding with reading an external file once the user has completed editing the syntax error being viewed.'!
'I am a ListView with a single item, the method or expression that created a syntax error when an attempt was made to read it from an external file. SyntaxErrorListController is my default controller.'!
"2/7/96 sw: no builds having yet been undertaken for our new kernel yet, this serves as a placeholder. carried forward in this method is some old code from macpal building, for future reference...
2/91: You must invoke this method from within a project that bears as its change-set all the changes in the system other than code residing in classes in the MacPal categories--otherewise the build files created will not be right. It does no harm to have changes relating to MacPal categories in the current changeset also, since these are stripped from it as part of the process. 8/91: Probably will now work fine with whatever changeset you have current; it will leave that current changeset holding all the non-pal changes. This is the hypothesis, anyway...
You must invoke this method from within a project that bears as its change-set all the changes in the system other than code residing in classes in the MacPal categories--otherwise the build files created will not be right
You have managed to enter the Non-MacPal-Changes project, perhaps in error!!
Choose 'enter' in the menu to the left to re-enter the main desktop project.
DO NOT request a ST noChanges when you can see this window!!
This project holds the incoming changes to non-MacPal classes in this version of the MacPal image.
It also serves as the project from within which build files are created for the next build. For this, you need to file in, while in this project, all the non-MacPal changes that have arisen since the incoming baseline image was built, even if they are already in the current image.
MacPalBuilder createBuildFiles."! !
!SystemBuilder class methodsFor: 'system building'!
buildingSystem
"Should be true only during system building. 1/18/96 sw"
"Reinitialize needs to be called manually after filing in the kernel because other support classes need to have been filed in before it can run successfully. This method copied over from old macPal stuff, 1/27/96 sw, to serve as a template, but the real work needs to be done still."
"Create and schedule a system category browser on the selected category
of classes."
self controlTerminate.
model buildSystemCategoryBrowser.
self controlInitialize!
classNotFound
view flash.
self controlInitialize!
edit
"Present the categories of system classes so that the user can view and
edit them."
view singleItemMode ifTrue: [^view flash].
self controlTerminate.
model editSystemCategories.
self controlInitialize!
fileOut
"Print a description of the classes in the selected system category onto an
external file."
self controlTerminate.
Cursor write showWhile:
[model fileOutSystemCategories].
self controlInitialize!
findClass
"modified 4/29/96 sw so that if only 1 class matches the user-supplied string, or if the user-supplied string exactly matches a class name, then the pop-up menu is bypassed"
'I represent a special dictionary that supports protocol for asking questions about the structure of the system. My only instance is Smalltalk whose entries are the global system variables, such as the classes and:
Disk -- a FileDirectory
Sensor -- an InputSensor
Display -- a DisplayScreen
StandardSystemControllers -- a ControlManager
Transcript -- a TextCollector
Processor -- a ProcessorScheduler
SourceFiles -- Array of FileStreams
SystemOrganization -- a SystemOrganizer
Mac -- an object used to make calls on the Mac Toolbox
StartUpList -- an OrderedCollection of objects with a method called StartUp that is called when Smalltalk starts up
StartUpList -- an OrderedCollection of objects with a method called ShutDown that is called when Smalltalk shuts down'!
"Create and schedule a message browser on each method that implements the message whose selector is in the argument selectorList. For example, Smalltalk browseAllImplementorsOf: #(at:put: size).
"Launch a browser on all methods whose source code contains aString as a substring. The search is case-sensitive. This takes a long time right now. 7/23/96 di"
"Launch a browser on all methods which contain string literals that have aString as a substring. The search is case-sensitive. This takes a long time right now. 2/1/96 sw"
| aList |
aList _ self allMethodsWithString: aString.
aList size > 0 ifTrue:
[Cursor normal show.
self browseMessageList: aList name: 'Methods with string ''', aString, '''']!
"Answer a SortedCollection of all the methods that contain, in a string literal, aString as a substring. 2/1/96 sw. The search is case-sensitive, and does not dive into complex literals, confining itself to string constants.
5/2/96 sw: fixed so that duplicate occurrences of aString in the same method don't result in duplicated entries in the browser"
"Shut down the source files if appropriate. 1/29/96 sw: changed so that the closing and nilification only take place if the entry was a FileStream, thus allowing stringified sources to remain in the saved image file"
1 to: 2 do: [:i |
((SourceFiles at: i) isKindOf: FileStream)
ifTrue:
[(SourceFiles at: i) close.
SourceFiles at: i put: nil]]!
copyright
"The Smalltalk copyright."
^'Copyright (c) Xerox Corp. 1981, 1982 All rights reserved.
Copyright (c) Apple Computer, Inc. 1985-1996 All rights reserved.'!
externalizeSources
"Write the sources and changes streams onto external files.
1/29/96 sw"
"Smalltalk externalizeSources"
"NB: openSourceFiles, actualContents, and fileExistsNamed: are symbols not yet in AST image 1/25/96 sw"
"Ensure that the changes file has been fully written to disk by closing and re-opening it. This makes the system more robust in the face of a power failure or hard-reboot."
| changesFile |
changesFile _ SourceFiles at: 2.
(changesFile isKindOf: FileStream) ifTrue: [
changesFile flush.
changesFile close.
changesFile open: changesFile name forWrite: true.
changesFile setToEnd.
].
!
internalizeChangeLog
"Smalltalk internalizeChangeLog"
"Bring the changes file into a memory-resident filestream, for faster access and freedom from external file system. 1/31/96 sw"
| reply aName aFile |
reply _ self confirm: 'CAUTION -- do not undertake this lightly!!
[newName _ newName copyFrom: 1 to: newName size - 6].
(dir includesKey: newName , '.image')
| (dir includesKey: newName , '.changes') ifTrue:
[^ self notify: newName , ' is already in use
Please choose another name.'].
dir copyFileNamed: self changesName toFileNamed: newName , '.changes'.
self logChange: '----SAVEAS ' , newName , '----'
, Date dateAndTimeNow printString.
self imageName: newName , '.image'.
self closeSourceFiles; openSourceFiles.
"Just so SNAPSHOT appears on the new file, and not the old"
self snapshot: true andQuit: false.!
shutDown
^ self closeSourceFiles!
snapshot: save andQuit: quit
"Mark the changes file and close all files. If save is true, save the current state of this Smalltalk in the image file. If quit is true, then exit to the outer shell. Note: latter part of this method runs when resuming a previously saved image.
1/17/96 sw: ripped out the disk-library maintenance stuff
5/8/96 sw: report snapshot/quit to transcript as well as chgs log"
| resuming msg |
save & (SourceFiles at: 2) notNil ifTrue:
[msg _ (quit
ifTrue: ['----QUIT----']
ifFalse: ['----SNAPSHOT----']), Date dateAndTimeNow printString.
"Primitive. Enter the machine language debugger, if one exists. Essential.
See Object documentation whatIsAPrimitive."
<primitive: 114>
self primitiveFailed!
newWorld
"return true iff we are running in the new world"
^ 999999 class == SmallInteger! !
!SystemDictionary methodsFor: 'profiling'!
clearProfile
"Clear the profile database."
<primitive: 250>
!
dumpProfile
"Dump the profile database to a file."
<primitive: 251>
!
profile: aBlock
"Make a virtual machine profile of the given block."
"Note: Profiling support is provided so that VM implementors
can better understand and improve the efficiency of the virtual
machine. To use it, you must be running a version of the
virtual machine compiled with profiling enabled (which
makes it much slower than normal even when not profiling).
You will also need the CodeWarrior profile reader application."
self stopProfiling.
self clearProfile.
self startProfiling.
aBlock value.
self stopProfiling.
self dumpProfile.!
startProfiling
"Start profiling the virtual machine."
<primitive: 252>
!
stopProfiling
"Stop profiling the virtual machine."
<primitive: 253>
! !ClassOrganizer subclass: #SystemOrganizer
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Support'!
SystemOrganizer comment:
'My instances provide an organization for the classes in the system, just as a ClassOrganizer organizes the messages within a class. The only difference is the methods for fileIn/Out.'!
!SystemOrganizer methodsFor: 'fileIn/Out'!
fileOutCategory: category
"Store on the file named category (a string) concatenated with '.st' all the
'I represent a String that has been marked with abstract changes in character appearance. Actual display is performed in the presence of a TextStyle which indicates, for each abstract code, an actual font to be used.'!
!Text methodsFor: 'accessing'!
at: index
^string at: index!
at: index put: character
^string at: index put: character!
atPin: index
^string atPin: index!
atWrap: index
^string atWrap: index!
findString: aString startingAt: start
"Answer the index of subString within the receiver, starting at index
start. If the receiver does not contain subString, answer 0."
'I am a kind of StringHolderController (a ParagraphEditor that adds the doIt, printIt, accept, and cancel commands). I do not change the yellow button menu. I do add methods for accepting text that was generated from Stream-like messages to the model, aTextCollector.'!
"The marginTabsArray is an Array of tuples. The Array is indexed according
to the marginIndex, the 'nesting' level of the requestor."
!
tabWidth
"Answer the width of a tab."
^DefaultTab! !
!TextStyle methodsFor: 'fonts and font indexes'!
collectionFromFileNamed: fileName
"Read the file. It is an Array of StrikeFonts. File format is the ReferenceStream version 2 format. For any fonts with new names, add them to DefaultTextStyle.fontArray.
To write out fonts: (TextStyle default fontArray saveOnFile2).
To read: (TextStyle default collectionFromFileNamed: 'new fonts')
*** Do not remove this method *** 8/19/96 tk"
| ff this names |
ff _ ReferenceStream fileNamed: fileName.
[this _ ff next.
this class == SmallInteger ifTrue: ["version number"].
"Currently there is no supporting protocol for changing these arrays. If an editor wishes to implement margin setting, then a copy of the default should be stored with these instance variables.
'A TranslucentColor behaves just like a normal color, except that it will pack its alpha value into the high byte of a 32-bit pixelValue. This allows creating forms with translucency for use with the alpha blend function of BitBlt.'!
!TranslucentColor methodsFor: 'equality'!
= aColor
^ super = aColor and: [aColor alpha = alpha]! !
!TranslucentColor methodsFor: 'conversions'!
pixelWordForDepth: depth
depth < 32 ifTrue: [^ super pixelWordForDepth: depth].
'I describe the behavior of my sole instance, nil. nil represents a prior value for variables that have not been initialized, or for results which are meaningless.'!
!UndefinedObject methodsFor: 'copying'!
deepCopy
"Only one instance of UndefinedObject should ever be made, so answer
with self."!
shallowCopy
"Only one instance of UndefinedObject should ever be made, so answer
with self."! !
!UndefinedObject methodsFor: 'printing'!
printOn: aStream
"Refer to the comment in Object|printOn:."
aStream nextPutAll: 'nil'!
storeOn: aStream
"Refer to the comment in Object|storeOn:."
aStream nextPutAll: 'nil'! !
!UndefinedObject methodsFor: 'testing'!
isExtant
^ false!
isNil
"Refer to the comment in Object|isNil."
^true!
notNil
"Refer to the comment in Object|notNil."
^false! !
!UndefinedObject methodsFor: 'dependents access'!
addDependent: ignored
"Refer to the comment in Object|addDependent:."
self error: 'Nil should not have dependents'!
release
"Nil release is a no-op"!
suspend
"Kills off processes that didn't terminate properly"
"Display reverse; reverse." "<-- So we can catch the suspend bug"
'A repository for general and miscellaneous utilities; much of what is here are in effect global methods that don''t naturally attach to anything else. 1/96 sw'!
report _ report, thisSize printString, Character tab, selector printString, Character cr.
total _ total + thisSize].
report _ report, '--- ------------------
'.
report _ report, total printString, Character tab, 'TOTAL
'.
^ report! !
!Utilities class methodsFor: 'identification'!
authorInitials
"Answer the initials to be used to identify the current code author. 1/18/96 sw"
^ AuthorInitials!
authorInitials: initials
"Set up the author initials for the system. Used in conjunction with cmd-shift-v to paste an authorship stamp. 1/18/96 sw"
"Utilities authorInitials: 'sw'"
AuthorInitials _ initials!
changeStamp
"Answer a string to be pasted into source code to mark who changed it and when. 1/17/96 sw"
^ Date today mmddyy, ' ', self authorInitials!
copyrightNotice
^ 'Copyright 1985-96, Apple Computer, Inc.'!
dateTimeSuffix
"Answer a string which indicates the date and time, intended for use in building fileout filenames, etc. 1/18/96 sw"
"Utilities dateTimeSuffix"
| dateTime headString tailString |
dateTime _ Time dateAndTimeNow.
headString _ dateTime first printString copyFrom: 1 to: 6.
headString _ headString copyWithout: $ .
tailString _ dateTime last printString copyWithout: $:.
^ headString, (tailString copyFrom: 1 to: tailString size - 5), (tailString copyFrom: tailString size -1 to: tailString size)! !
!Utilities class methodsFor: 'support windows'!
commandKeyMappings
^ self class firstCommentAt: #commandKeyMappings
"Lower-case command keys
a Select all
b Browse it
c Copy
d Do it
e Exchange
f Find
g Find again
h Set Search String
i Inspect it
j Again once
k Set font
l Cancel
m Implementors of it
n Senders of it
o Spawn
p Print it
q Query symbol
r Recognizer
s Save (i.e. accept)
u Align
v Paste
w Delete preceding word
x Cut
y Swap characters
z Undo
Upper-case command keys (Hold down Cmd & Shift, or Ctrl key)
A Advance argument
B Browse it in this same browser (in System browsers only)
C Compare argument to clipboard
D Duplicate
F Insert 'ifFalse:'
J Again many
K Set style
L Outdent (move selection one tab-stop left)
N References to it
R Indent (move selection one tab-stap right)
S Search
T Insert 'ifTrue:'
W Selectors containing it
V Paste author's initials
esc Select current type-in
[ Enclose within [ and ], or remove enclosing [ and ]
( Enclose within ( and ), or remove enclosing ( and ) NB: use ctrl (
{ Enclose within { and }, or remove enclosing { and }
< Enclose within < and >, or remove enclosing < and >
' Enclose within ' and ', or remove enclosing ' and '
"" Enclose within "" and "", or remove enclosing "" and ""
0 10 point plain serif
1 10 point bold serif
2 10 point italic serif
3 12 point plain serif
4 12 point bold serif
5 12 point italic serif
6 10 point plain sans-serif
7 10 point bold sans-serif
8 10 point underline serif
9 12 point plain sans-serif
"
"Answer a string to be presented in a window at user request as a crib sheet for command-key mappings. 2/7/96 sw
5/1/96 sw: modified so that the long string lives in a comment, hence doesn't take up memory. Also, fixed up some of the actual text, and added help for parentheses-enclosing items and text-style controls.
5/10/96 sw: added a bunch of changes at JM's suggestion
8/11/96 sw: fixed the font sizes, added align & references to it, and help for cmd-shift-B"!
openCommandKeyHelp
"Open a window giving command key help. 1/17/96 sw"
"Put a message above (or below if insufficient room) the cursor.
1/22/96 sw"
"Utilities informUser: 'How do you do' while: [Sensor anyButtonPressed not]"
| cp |
cp _ Sensor cursorPoint.
(PopUpMenu labels: '') displayAt: cp
withCaption: aString
during: [[aBlock value] whileTrue]!
logToUser: aMessage
"For now, we just show in the Smalltalk transcript, but when/if we have a permanent user control panel, we could divert such messages to that panel. sw"
"The mouse has gone down in box; track the mouse, inverting the box while it's within, and if, on mouse up, the cursor was still within the box, execute succBlock. While waiting for the mouse to come up, repeatedly execute doBlock. 5/11/96 sw
6/10/96 sw: call new method that adds extra feature"
"The mouse has gone down in box; track the mouse, inverting the box while it's within, and if, on mouse up, the cursor was still within the box, execute succBlock. While waiting for the mouse to come up, repeatedly execute doBlock1, and also, if the cursor is within the box, execute doBlock2. 6/10/96 sw"
"Return a key like aString that satisfies aBlock. The block should provide a test for acceptability -- typically the test is about whether the key is already in use. aBlock should return a boolean. 8/11/96 sw"
"Return a key like (aString, trailerString) that satisfies aBlock. The block should provide a test for acceptability -- typically the test is about whether the key is already in use. aBlock should return a boolean. 8/11/96 sw"
"evaluate aString in the given context, and return the result. 2/2/96 sw"
| result |
result _ Compiler new
evaluate: aString
in: aContext
to: aReceiver
notifying: nil
ifFail: [^ #failedDoit].
^ result!
initialize
"Initialize the class variables. 5/16/96 sw"
self initializeCommonRequestStrings.
RecentSubmissions _ OrderedCollection new!
initializeCommonRequestStrings
"Initialize an array of common request strings. 2/1/96 sw
5/10/96 sw: converted over to new format of StringHolder"
CommonRequestStrings _ StringHolder new contents:
'Sensor keyboard
Curor normal show
Transcript cr; show: ''testing''
Smalltalk sendersOf: #hot
Utilities emergencyCollapse
CharRecog reinitializeCharacterDictionary'
"Utilities initializeCommonRequestStrings"!
offerCommonRequests
"Offer up the common-requests menu. If the user chooses one, then evaluate it, and -- provided the value is anumber or string -- show it in the Transcript. Revised technique 5/10/96 sw as per a suggestion from JM
6/6/96 sw: bug fix: if no choice, don't treat it as if the first item was chosen"
"Utilities offerCommonRequests"
| reply result aMenu index normalItemCount strings |
"Display the given array of forms across the top of the screen, wrapping to subsequent lines if needed. Useful for example for looking at sets of rotations and animations. 6/10/96 sw"
"Display the given Dictionary of forms across the top of the screen, wrapping to subsequent lines if needed. Beneath each, put the name of the associated key."
'My instances are intended to be components in a structured picture. Each View in the structured picture can contain other Views as sub-components. These sub-components are called subViews. A View can be a subView of only one View. This View is called its superView. The set of Views in a structured picture forms a hierarchy. The one View in the hierarchy that has no superView is called the topView of the structured picture. A View in a structured picture with no subViews is called a bottom View. A View and all of its subViews, and all of their subViews and so on, are treated as a unit in many operations on the View. For example, if a View is displayed, all of its subViews are displayed as well. There are several categories of operations that can be performed on a View. Among these are the following:
1. Adding subViews to a View.
2. Positioning subViews within a View.
3. Deleting subViews from a View.
4. Transforming a View.
5. Displaying a View.
Each View has its own coordinate system. In order to change from one coordinate system to another, each View has two transformations associated with it. The local transformation is a WindowingTransformation that maps objects in the coordinate system of the View to objects in the coordinate system of the superView of the View. The displayTransformation is a WindowingTransformation that maps objects in the coordinate system of the View to objects in the display screen coordinate system.
The part of the space that is to be made visible is represented by the window of the View. The window of a View is a Rectangle expressed in the coordinate system of the View. The area occupied by a View in the coordinate system of its superView is called its viewport. The viewport of a View is its window transformed by its local transformation. The region of the display screen occupied by a View is called its displayBox. The display box of a View can include a border. The width of the border expressed in display screen coordinates is called the border width of the View. The color of the border is called the border color. The region of the display box of a View excluding the border is called the inset display box. The color of the inset display box is called the inside color of the View.'!
!View methodsFor: 'initialize-release'!
initialize
"Initialize the state of the receiver. Subclasses should include 'super
initialize' when redefining this message to insure proper initialization."
"Obtain the background color from the receiver's model, unless the #uniformWindowColors preference is set to true, in which case obtain it from generic Object; and install it as the receiver's background color. 5/1/96 sw"
| colorToUse |
colorToUse _ Preferences uniformWindowColors
ifTrue:
[Object new defaultBackgroundColor]
ifFalse:
[model defaultBackgroundColor].
self backgroundColor: colorToUse! !
!View methodsFor: 'testing'!
containsPoint: aPoint
"Answer whether aPoint is within the receiver's display box. It is sent to
a View's subViews by View|subViewAt: in order to determine which
subView contains the cursor point (so that, for example, control can be
pass down to that subView's controller).
1/24/96 sw: use insetDisplayBox, so border doesn't count"
"Answer true if aView is the same as this View or its superView, false
otherwise."
self == aView ifTrue: [^true].
self isTopView ifTrue: [^false].
^superView isCyclic: aView!
setTransformation: aTransformation
"Set the View's local transformation to aTransformation, unlock the View
(see View|unlock), and set the viewport to undefined (this forces it to be
recomputed when needed). Should be used instead of setting the
transformation directly."
transformation _ aTransformation.
self unlock.
viewport _ nil!
setWindow: aWindow
"Set the View's window to aWindow and unlock the View (see
View|unlock). View|setWindow should be used by methods of View and
subclasses to set the View window (rather than directly setting the
instance variable) to insure that the View is unlocked."
window _ aWindow.
viewport _ nil.
self unlock!
superView: aView
"Set the View's superView to aView and unlock the View (see
View|unlock). It is sent by View|addSubView: in order to properly set all
the links."
superView _ aView.
self unlock! !
!View methodsFor: 'miscellaneous'!
accepted
"The user has told the receiver's controller to accept the current contents. Take appropriate action if desired. This place-holder provides a mechanism for intercepting the user's 'accept' request. 7/16/96 sw"!
clipRect
^ superView clipRect!
clipRect: r
superView clipRect: r!
grid: aPoint
^ superView grid: aPoint!
gridSpacing
^ superView gridSpacing!
nestedViewport
"The viewport size used to control scaling of nested user views."
'WarpBlt is a little warp-drive added on to BitBlt. It takes a quadrilateral as its source specification, while its destination is traversed and combined just like any other call to copyBits.
The source quadrilateral is specified as an array of points starting with the corner that wants to end up in the topLeft, and proceding to the successive points that want to follow CCW around the destination rectangle. Note that in specifying a plain old rectangle source, its non topLeft points must be actual pixels, not outside by 1, as with rectangle bottmRight, eg. See the method Rectangle asQuad.
WarpBlt does a fast job of rotation, reflection and scaling, and it can even produce a semblance of perspective. Depth parameters are included for future improvements in this direction. but the primitve does not support this yet.'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex pan: pan
"Play samples from a wave table by stepping a fixed amount throught the table on every sample. The decay parameter may be used to make the sound fade away, but its default value of 1.0 produces a sustained sound, like a flute. The abrupt start and stops of this sound result in transient clicks; it would benefit greatly from a simple attack-sustain-decay envelope."
'My instances are used to transform objects from a source coordinate system to a destination coordinate system. Each instance contains a scale and a translation which can be applied to objects that respond to scaleBy: and translateBy:. It can be created with a default identity scale and translation, or with a specified scale and translation, or with a scale and translation computed from a window (a Rectangle in the source coordinate system) and a viewport (a Rectangle in the destination coordinate system). In applying a WindowingTransformation to an object, the object is first scaled (around the origin of the source coordinate system) and then translated. WindowingTransformations can be composed to form a single compound transformation.'!
!WindowingTransformation methodsFor: 'scrolling'!
scrollBy: aPoint
"Answer a WindowingTransformation with the same scale as the receiver
and with a translation of the current translation plus aPoint scaled by
the current scale. It is used when the translation is known in source
coordinates, rather than scaled source coordinates (see
WindowingTransformation|translateBy:). An example is that of scrolling
objects with respect to a stationary window in the source coordinate
system. If no scaling is in effect (scale = nil), then
WindowingTransformation|translateBy: and
WindowingTransformation|scrollBy: are equivalent."
