[Pkg] The Trunk: Collections-kfr.9.mcz
commits at source.squeak.org
commits at source.squeak.org
Mon Aug 29 13:03:09 UTC 2016
Tim Felgentreff uploaded a new version of Collections to project The Trunk:
http://source.squeak.org/trunk/Collections-kfr.9.mcz
==================== Summary ====================
Name: Collections-kfr.9
Author: kfr
Time: 5 December 2012, 4:58:43 pm
UUID: cbcd8469-2a1a-e247-848b-b3d559df006c
Ancestors: Collections-kfr.8
Fix long standing bug with printing small numbers ie 1.2245678e-16
Copied method from Squeak 4.4
==================== Snapshot ====================
SystemOrganization addCategory: #'Collections-Abstract'!
SystemOrganization addCategory: #'Collections-Arrayed'!
SystemOrganization addCategory: #'Collections-Sequenceable'!
SystemOrganization addCategory: #'Collections-SkipLists'!
SystemOrganization addCategory: #'Collections-Streams'!
SystemOrganization addCategory: #'Collections-Strings'!
SystemOrganization addCategory: #'Collections-Support'!
SystemOrganization addCategory: #'Collections-Text'!
SystemOrganization addCategory: #'Collections-Unordered'!
SystemOrganization addCategory: #'Collections-Weak'!
Magnitude subclass: #Character
instanceVariableNames: 'value'
classVariableNames: 'CharacterTable ClassificationTable LetterBits LowercaseBit UppercaseBit'
poolDictionaries: ''
category: 'Collections-Strings'!
!Character commentStamp: 'ar 4/9/2005 22:35' prior: 0!
I represent a character by storing its associated Unicode. The first 256 characters are created uniquely, so that all instances of latin1 characters ($R, for example) are identical.
The code point is based on Unicode. Since Unicode is 21-bit wide character set, we have several bits available for other information. As the Unicode Standard states, a Unicode code point doesn't carry the language information. This is going to be a problem with the languages so called CJK (Chinese, Japanese, Korean. Or often CJKV including Vietnamese). Since the characters of those languages are unified and given the same code point, it is impossible to display a bare Unicode code point in an inspector or such tools. To utilize the extra available bits, we use them for identifying the languages. Since the old implementation uses the bits to identify the character encoding, the bits are sometimes called "encoding tag" or neutrally "leading char", but the bits rigidly denotes the concept of languages.
The other languages can have the language tag if you like. This will help to break the large default font (font set) into separately loadable chunk of fonts. However, it is open to the each native speakers and writers to decide how to define the character equality, since the same Unicode code point may have different language tag thus simple #= comparison may return false.
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.!
----- Method: Character class>>allByteCharacters (in category 'instance creation') -----
allByteCharacters
"Answer all the characters that can be encoded in a byte"
^ (0 to: 255) collect: [:v | Character value: v]
!
----- Method: Character class>>allCharacters (in category 'instance creation') -----
allCharacters
"This name is obsolete since only the characters that will fit in a byte can be queried"
^self allByteCharacters
!
----- Method: Character class>>alphabet (in category 'constants') -----
alphabet
"($a to: $z) as: String"
^ 'abcdefghijklmnopqrstuvwxyz' copy!
----- Method: Character class>>arrowDown (in category 'accessing untypeable characters') -----
arrowDown
^ self value: 31!
----- Method: Character class>>arrowLeft (in category 'accessing untypeable characters') -----
arrowLeft
^ self value: 28!
----- Method: Character class>>arrowRight (in category 'accessing untypeable characters') -----
arrowRight
^ self value: 29!
----- Method: Character class>>arrowUp (in category 'accessing untypeable characters') -----
arrowUp
^ self value: 30!
----- Method: Character class>>backspace (in category 'accessing untypeable characters') -----
backspace
"Answer the Character representing a backspace."
^self value: 8!
----- Method: Character class>>characterTable (in category 'constants') -----
characterTable
"Answer the class variable in which unique Characters are stored."
^CharacterTable!
----- Method: Character class>>cr (in category 'accessing untypeable characters') -----
cr
"Answer the Character representing a carriage return."
^self value: 13!
----- Method: Character class>>delete (in category 'accessing untypeable characters') -----
delete
^ self value: 127!
----- Method: Character class>>digitValue: (in category 'instance creation') -----
digitValue: x
"Answer the Character whose digit value is x. For example, answer $9 for
x=9, $0 for x=0, $A for x=10, $Z for x=35."
| index |
index _ x asInteger.
^CharacterTable at:
(index < 10
ifTrue: [48 + index]
ifFalse: [55 + index])
+ 1!
----- Method: Character class>>end (in category 'accessing untypeable characters') -----
end
^ self value: 4!
----- Method: Character class>>enter (in category 'accessing untypeable characters') -----
enter
"Answer the Character representing enter."
^self value: 3!
----- Method: Character class>>escape (in category 'accessing untypeable characters') -----
escape
"Answer the ASCII ESC character"
^self value: 27!
----- Method: Character class>>euro (in category 'accessing untypeable characters') -----
euro
"The Euro currency sign, that E with two dashes. The key code is a wild guess"
^ Character value: 219!
----- Method: Character class>>home (in category 'accessing untypeable characters') -----
home
^ self value: 1!
----- Method: Character class>>initialize (in category 'class initialization') -----
initialize
"Create the table of unique Characters."
" self initializeClassificationTable"!
----- Method: Character class>>initializeClassificationTable (in category 'class initialization') -----
initializeClassificationTable
"
Initialize the classification table. The classification table is a
compact encoding of upper and lower cases of characters with
- bits 0-7: The lower case value of this character.
- bits 8-15: The upper case value of this character.
- bit 16: lowercase bit (e.g., isLowercase == true)
- bit 17: uppercase bit (e.g., isUppercase == true)
"
| ch1 ch2 |
LowercaseBit := 1 bitShift: 16.
UppercaseBit := 1 bitShift: 17.
"Initialize the letter bits (e.g., isLetter == true)"
LetterBits := LowercaseBit bitOr: UppercaseBit.
ClassificationTable := Array new: 256.
"Initialize the defaults (neither lower nor upper case)"
0 to: 255 do:[:i|
ClassificationTable at: i+1 put: (i bitShift: 8) + i.
].
"Initialize character pairs (upper-lower case)"
#(
"Basic roman"
($A $a) ($B $b) ($C $c) ($D $d)
($E $e) ($F $f) ($G $g) ($H $h)
($I $i) ($J $j) ($K $k) ($L $l)
($M $m) ($N $n) ($O $o) ($P $p)
($Q $q) ($R $r) ($S $s) ($T $t)
($U $u) ($V $v) ($W $w) ($X $x)
($Y $y) ($Z $z)
"International"
($Ä $ä) ($Å $å) ($Ç $ç) ($É $é)
($Ñ $ñ) ($Ö $ö) ($Ü $ü) ($À $à)
($à $ã) ($Õ $õ) ($Œ $œ) ($Æ $æ)
"International - Spanish"
($Á $á) ($Í $í) ($Ó $ó) ($Ú $ú)
"International - PLEASE CHECK"
($È $è) ($Ì $ì) ($Ò $ò) ($Ù $ù)
($Ë $ë) ($Ï $ï)
($Â $â) ($Ê $ê) ($Î $î) ($Ô $ô) ($Û $û)
) do:[:pair|
ch1 := pair first asciiValue.
ch2 := pair last asciiValue.
ClassificationTable at: ch1+1 put: (ch1 bitShift: 8) + ch2 + UppercaseBit.
ClassificationTable at: ch2+1 put: (ch1 bitShift: 8) + ch2 + LowercaseBit.
].
"Initialize a few others for which we only have lower case versions."
#($ß $Ø $ø $ÿ) do:[:char|
ch1 := char asciiValue.
ClassificationTable at: ch1+1 put: (ch1 bitShift: 8) + ch1 + LowercaseBit.
].
!
----- Method: Character class>>insert (in category 'accessing untypeable characters') -----
insert
^ self value: 5!
----- Method: Character class>>leadingChar:code: (in category 'instance creation') -----
leadingChar: leadChar code: code
code >= 16r400000 ifTrue: [
self error: 'code is out of range'.
].
leadChar >= 256 ifTrue: [
self error: 'lead is out of range'.
].
^self value: (leadChar bitShift: 22) + code.!
----- Method: Character class>>lf (in category 'accessing untypeable characters') -----
lf
"Answer the Character representing a linefeed."
^self value: 10!
----- Method: Character class>>linefeed (in category 'accessing untypeable characters') -----
linefeed
"Answer the Character representing a linefeed."
^self value: 10!
----- Method: Character class>>nbsp (in category 'accessing untypeable characters') -----
nbsp
"non-breakable space."
^ Character value: 202!
----- Method: Character class>>new (in category 'instance creation') -----
new
"Creating new characters is not allowed."
self error: 'cannot create new characters'!
----- Method: Character class>>newPage (in category 'accessing untypeable characters') -----
newPage
"Answer the Character representing a form feed."
^self value: 12!
----- Method: Character class>>pageDown (in category 'accessing untypeable characters') -----
pageDown
^ self value: 12!
----- Method: Character class>>pageUp (in category 'accessing untypeable characters') -----
pageUp
^ self value: 11!
----- Method: Character class>>separators (in category 'instance creation') -----
separators
^ #(32 "space"
13 "cr"
9 "tab"
10 "line feed"
12 "form feed")
collect: [:v | Character value: v]
!
----- Method: Character class>>space (in category 'accessing untypeable characters') -----
space
"Answer the Character representing a space."
^self value: 32!
----- Method: Character class>>tab (in category 'accessing untypeable characters') -----
tab
"Answer the Character representing a tab."
^self value: 9!
----- Method: Character class>>value: (in category 'instance creation') -----
value: anInteger
"Answer the Character whose value is anInteger."
anInteger > 255 ifTrue: [^self basicNew setValue: anInteger].
^ CharacterTable at: anInteger + 1.
!
----- Method: Character>>< (in category 'comparing') -----
< aCharacter
"Answer true if the receiver's value < aCharacter's value."
^self asciiValue < aCharacter asciiValue!
----- Method: Character>>= (in category 'comparing') -----
= aCharacter
"Primitive. Answer true if the receiver and the argument are the same
object (have the same object pointer) and false otherwise. Optional. See
Object documentation whatIsAPrimitive."
^ self == aCharacter or:[
aCharacter isCharacter and: [self asciiValue = aCharacter asciiValue]]!
----- Method: Character>>> (in category 'comparing') -----
> aCharacter
"Answer true if the receiver's value > aCharacter's value."
^self asciiValue > aCharacter asciiValue!
----- Method: Character>>asCharacter (in category 'converting') -----
asCharacter
"Answer the receiver itself."
^self!
----- Method: Character>>asIRCLowercase (in category 'converting') -----
asIRCLowercase
"convert to lowercase, using IRC's rules"
self == $[ ifTrue: [ ^ ${ ].
self == $] ifTrue: [ ^ $} ].
self == $\ ifTrue: [ ^ $| ].
^self asLowercase!
----- Method: Character>>asInteger (in category 'converting') -----
asInteger
"Answer the value of the receiver."
^value!
----- Method: Character>>asLowercase (in category 'converting') -----
asLowercase
"If the receiver is uppercase, answer its matching lowercase Character."
"A tentative implementation. Eventually this should consult the Unicode table."
| v |
v _ self charCode.
(((8r101 <= v and: [v <= 8r132]) or: [16rC0 <= v and: [v <= 16rD6]]) or: [16rD8 <= v and: [v <= 16rDE]])
ifTrue: [^ Character value: value + 8r40]
ifFalse: [^ self]!
----- Method: Character>>asString (in category 'converting') -----
asString
^ String with: self!
----- Method: Character>>asSymbol (in category 'converting') -----
asSymbol
"Answer a Symbol consisting of the receiver as the only element."
^Symbol internCharacter: self!
----- Method: Character>>asText (in category 'converting') -----
asText
^ self asString asText!
----- Method: Character>>asUnicode (in category 'converting') -----
asUnicode
| table charset v |
self leadingChar = 0 ifTrue: [^ value].
charset _ EncodedCharSet charsetAt: self leadingChar.
charset isCharset ifFalse: [^ self charCode].
table _ charset ucsTable.
table isNil ifTrue: [^ 16rFFFD].
v _ table at: self charCode + 1.
v = -1 ifTrue: [^ 16rFFFD].
^ v.
!
----- Method: Character>>asUnicodeChar (in category 'converting') -----
asUnicodeChar
"@@@ FIXME: Make this use asUnicode and move it to its lonely sender @@@"
| table charset v |
self leadingChar = 0 ifTrue: [^ value].
charset _ EncodedCharSet charsetAt: self leadingChar.
charset isCharset ifFalse: [^ self].
table _ charset ucsTable.
table isNil ifTrue: [^ Character value: 16rFFFD].
v _ table at: self charCode + 1.
v = -1 ifTrue: [^ Character value: 16rFFFD].
^ Character leadingChar: charset unicodeLeadingChar code: v.!
----- Method: Character>>asUppercase (in category 'converting') -----
asUppercase
"If the receiver is lowercase, answer its matching uppercase Character."
"A tentative implementation. Eventually this should consult the Unicode table."
| v |
v _ self charCode.
(((8r141 <= v and: [v <= 8r172]) or: [16rE0 <= v and: [v <= 16rF6]]) or: [16rF8 <= v and: [v <= 16rFE]])
ifTrue: [^ Character value: value - 8r40]
ifFalse: [^ self]
!
----- Method: Character>>asciiValue (in category 'accessing') -----
asciiValue
"Answer the value of the receiver that represents its ascii encoding."
^value!
----- Method: Character>>basicSqueakToIso (in category 'converting') -----
basicSqueakToIso
| asciiValue |
value < 128 ifTrue: [^ self].
value > 255 ifTrue: [^ self].
asciiValue _ #(196 197 199 201 209 214 220 225 224 226 228 227 229 231 233 232 234 235 237 236 238 239 241 243 242 244 246 245 250 249 251 252 134 176 162 163 167 149 182 223 174 169 153 180 168 128 198 216 129 177 138 141 165 181 142 143 144 154 157 170 186 158 230 248 191 161 172 166 131 173 178 171 187 133 160 192 195 213 140 156 150 151 147 148 145 146 247 179 253 159 185 164 139 155 188 189 135 183 130 132 137 194 202 193 203 200 205 206 207 204 211 212 190 210 218 219 217 208 136 152 175 215 221 222 184 240 254 255 256 ) at: self asciiValue - 127.
^ Character value: asciiValue.
!
----- Method: Character>>canBeGlobalVarInitial (in category 'testing') -----
canBeGlobalVarInitial
^ (EncodedCharSet charsetAt: self leadingChar) canBeGlobalVarInitial: self.
!
----- Method: Character>>canBeNonGlobalVarInitial (in category 'testing') -----
canBeNonGlobalVarInitial
^ (EncodedCharSet charsetAt: self leadingChar) canBeNonGlobalVarInitial: self.
!
----- Method: Character>>charCode (in category 'accessing') -----
charCode
^ (value bitAnd: 16r3FFFFF).
!
----- Method: Character>>clone (in category 'copying') -----
clone
"Answer with the receiver, because Characters are unique."!
----- Method: Character>>comeFullyUpOnReload: (in category 'object fileIn') -----
comeFullyUpOnReload: smartRefStream
"Use existing an Character. Don't use the new copy."
^ self class value: value!
----- Method: Character>>copy (in category 'copying') -----
copy
"Answer with the receiver because Characters are unique."!
----- Method: Character>>deepCopy (in category 'copying') -----
deepCopy
"Answer with the receiver because Characters are unique."!
----- Method: Character>>digitValue (in category 'accessing') -----
digitValue
"Answer 0-9 if the receiver is $0-$9, 10-35 if it is $A-$Z, and < 0
otherwise. This is used to parse literal numbers of radix 2-36."
^ (EncodedCharSet charsetAt: self leadingChar) digitValue: self.
!
----- Method: Character>>hash (in category 'comparing') -----
hash
"Hash is reimplemented because = is implemented."
^value!
----- Method: Character>>hex (in category 'printing') -----
hex
^value hex!
----- Method: Character>>isAlphaNumeric (in category 'testing') -----
isAlphaNumeric
"Answer whether the receiver is a letter or a digit."
^self isLetter or: [self isDigit]!
----- Method: Character>>isCharacter (in category 'testing') -----
isCharacter
^ true.
!
----- Method: Character>>isDigit (in category 'testing') -----
isDigit
^ (EncodedCharSet charsetAt: self leadingChar) isDigit: self.
!
----- Method: Character>>isLetter (in category 'testing') -----
isLetter
^ (EncodedCharSet charsetAt: self leadingChar) isLetter: self.
!
----- Method: Character>>isLiteral (in category 'printing') -----
isLiteral
^true!
----- Method: Character>>isLowercase (in category 'testing') -----
isLowercase
^ (EncodedCharSet charsetAt: self leadingChar) isLowercase: self.
!
----- Method: Character>>isOctetCharacter (in category 'testing') -----
isOctetCharacter
^ value < 256.
!
----- Method: Character>>isSafeForHTTP (in category 'testing') -----
isSafeForHTTP
"whether a character is 'safe', or needs to be escaped when used, eg, in a URL"
"[GG] See http://www.faqs.org/rfcs/rfc1738.html. ~ is unsafe and has been removed"
^ self charCode < 128
and: [self isAlphaNumeric
or: ['.-_' includes: (Character value: self charCode)]]!
----- Method: Character>>isSeparator (in category 'testing') -----
isSeparator
"Answer whether the receiver is one of the separator characters--space,
cr, tab, line feed, or form feed."
value = 32 ifTrue: [^true]. "space"
value = 13 ifTrue: [^true]. "cr"
value = 9 ifTrue: [^true]. "tab"
value = 10 ifTrue: [^true]. "line feed"
value = 12 ifTrue: [^true]. "form feed"
^false!
----- Method: Character>>isSpecial (in category 'testing') -----
isSpecial
"Answer whether the receiver is one of the special characters"
^'+-/\*~<>=@,%|&?!!' includes: self!
----- Method: Character>>isTraditionalDomestic (in category 'testing') -----
isTraditionalDomestic
"Yoshiki's note about #isUnicode says:
[This method] is for the backward compatibility when we had domestic
traditional encodings for CJK languages. To support loading the
projects in traditional domestic encodings (From Nihongo4), and load
some changesets. Once we decided to get rid of classes like JISX0208
from the EncodedCharSet table, the need for isUnicode will not be
necessary.
I (Andreas) decided to change the name from isUnicode to #isTraditionalDomestic
since I found isUnicode to be horribly confusing (how could the character *not*
be Unicode after all?). But still, we should remove this method in due time."
^ ((EncodedCharSet charsetAt: self leadingChar) isKindOf: LanguageEnvironment class) not!
----- Method: Character>>isUppercase (in category 'testing') -----
isUppercase
^ (EncodedCharSet charsetAt: self leadingChar) isUppercase: self.
!
----- Method: Character>>isVowel (in category 'testing') -----
isVowel
"Answer whether the receiver is one of the vowels, AEIOU, in upper or
lower case."
^'AEIOU' includes: self asUppercase!
----- Method: Character>>isoToSqueak (in category 'converting') -----
isoToSqueak
^self "no longer needed"!
----- Method: Character>>leadingChar (in category 'accessing') -----
leadingChar
^ (value bitAnd: (16r3FC00000)) bitShift: -22.
!
----- Method: Character>>macToSqueak (in category 'converting') -----
macToSqueak
"Convert the receiver from MacRoman to Squeak encoding"
| asciiValue |
value < 128 ifTrue: [^ self].
value > 255 ifTrue: [^ self].
asciiValue _ #(196 197 199 201 209 214 220 225 224 226 228 227 229 231 233 232 234 235 237 236 238 239 241 243 242 244 246 245 250 249 251 252 134 176 162 163 167 149 182 223 174 169 153 180 168 128 198 216 129 177 138 141 165 181 142 143 144 154 157 170 186 158 230 248 191 161 172 166 131 173 178 171 187 133 160 192 195 213 140 156 150 151 147 148 145 146 247 179 255 159 185 164 139 155 188 189 135 183 130 132 137 194 202 193 203 200 205 206 207 204 211 212 190 210 218 219 217 208 136 152 175 215 221 222 184 240 253 254 ) at: self asciiValue - 127.
^ Character value: asciiValue.
!
----- Method: Character>>objectForDataStream: (in category 'object fileIn') -----
objectForDataStream: refStrm
"I am being collected for inclusion in a segment. Do not include Characters!! Let them be in outPointers."
refStrm insideASegment
ifFalse: ["Normal use" ^ self]
ifTrue: ["recording objects to go into an ImageSegment"
"remove it from references. Do not trace."
refStrm references removeKey: self ifAbsent: [].
^ nil]
!
----- Method: Character>>printOn: (in category 'printing') -----
printOn: aStream
aStream nextPut: $$.
aStream nextPut: self!
----- Method: Character>>printOnStream: (in category 'printing') -----
printOnStream: aStream
aStream print:'$', (String with:self).!
----- Method: Character>>setValue: (in category 'private') -----
setValue: newValue
value ifNotNil:[^self error:'Characters are immutable'].
value _ newValue.!
----- Method: Character>>sissSequence (in category 'converting') -----
sissSequence
"This method omits the language tags. So, shouldn't be used for WideChars casually."
| masked s low high escapeBlock |
masked _ value bitAnd: 16r1FFFFF.
masked = 7 ifTrue: [^ '\a'].
masked = 8 ifTrue: [^ '\b'].
masked = 9 ifTrue: [^ '\t'].
masked = 10 ifTrue: [^ '\n'].
masked = 11 ifTrue: [^ '\v'].
masked = 12 ifTrue: [^ '\f'].
masked = 13 ifTrue: [^ '\r'].
masked = 27 ifTrue: [^ '\e'].
masked = 34 ifTrue: [^ '\"'].
"masked = 39 ifTrue: [^ '\''']."
masked = 92 ifTrue: [^ '\\'].
(32 <= masked and: [masked < 128]) ifTrue: [
^ self asString.
].
escapeBlock _ [:marker :digits |
s _ String new: digits + 2.
s at: 1 put: $\.
s at: 2 put: marker.
digits + 2 to: 3 by: -1 do: [:i |
s at: i put: ('0123456789ABCDEF' at: (masked \\ 16) + 1).
masked _ masked bitShift: -4
].
^ s
].
(masked < 32 or: [masked > 127 and: [masked < 256]]) ifTrue: [
escapeBlock value: $x value: 2.
].
((256 <= masked) and: [masked <= 16rFFFF]) ifTrue: [
escapeBlock value: $u value: 4.
].
low _ (masked \\ 16r400) + 16rDC00.
high _ (masked // 16r400) + 16rD800.
^ (Character value: high) sissSequence, (Character value: low) sissSequence.
!
----- Method: Character>>sissUnescape (in category 'converting') -----
sissUnescape
self = $a ifTrue: [^ Character value: 7].
self = $b ifTrue: [^ Character value: 8].
self = $t ifTrue: [^ Character value: 9].
self = $n ifTrue: [^ Character value: 10].
self = $v ifTrue: [^ Character value: 11].
self = $f ifTrue: [^ Character value: 12].
self = $r ifTrue: [^ Character value: 13].
self = $e ifTrue: [^ Character value: 27].
^ self.
!
----- Method: Character>>squeakToIso (in category 'converting') -----
squeakToIso
^self "no longer needed"!
----- Method: Character>>squeakToMac (in category 'converting') -----
squeakToMac
"Convert the receiver from Squeak to MacRoman encoding."
value < 128 ifTrue: [^ self].
value > 255 ifTrue: [^ self].
^ Character value: (#(
173 176 226 196 227 201 160 224 246 228 178 220 206 179 182 183 "80-8F"
184 212 213 210 211 165 208 209 247 170 185 221 207 186 189 217 "90-9F"
202 193 162 163 219 180 195 164 172 169 187 199 194 197 168 248 "A0-AF"
161 177 198 215 171 181 166 225 252 218 188 200 222 223 240 192 "B0-BF"
203 231 229 204 128 129 174 130 233 131 230 232 237 234 235 236 "C0-CF"
245 132 241 238 239 205 133 249 175 244 242 243 134 250 251 167 "D0-DF"
136 135 137 139 138 140 190 141 143 142 144 145 147 146 148 149 "E0-EF"
253 150 152 151 153 155 154 214 191 157 156 158 159 254 255 216 "F0-FF"
) at: value - 127)
!
----- Method: Character>>storeBinaryOn: (in category 'printing') -----
storeBinaryOn: aStream
"Store the receiver on a binary (file) stream"
value < 256
ifTrue:[aStream basicNextPut: self]
ifFalse:[Stream nextInt32Put: value].!
----- Method: Character>>storeOn: (in category 'printing') -----
storeOn: aStream
"Character literals are preceded by '$'."
aStream nextPut: $$; nextPut: self!
----- Method: Character>>to: (in category 'converting') -----
to: other
"Answer with a collection in ascii order -- $a to: $z"
^ (self asciiValue to: other asciiValue) collect:
[:ascii | Character value: ascii]!
----- Method: Character>>tokenish (in category 'testing') -----
tokenish
"Answer whether the receiver is a valid token-character--letter, digit, or
colon."
^self isLetter or: [self isDigit or: [self = $:]]!
----- Method: Character>>veryDeepCopyWith: (in category 'copying') -----
veryDeepCopyWith: deepCopier
"Return self. I can't be copied."!
Magnitude subclass: #LookupKey
instanceVariableNames: 'key'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Support'!
!LookupKey commentStamp: '<historical>' prior: 0!
I represent a key for looking up entries in a data structure. Subclasses of me, such as Association, typically represent dictionary entries.!
LookupKey subclass: #Association
instanceVariableNames: 'value'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Support'!
!Association commentStamp: '<historical>' prior: 0!
I represent a pair of associated objects--a key and a value. My instances can serve as entries in a dictionary.!
----- Method: Association class>>key:value: (in category 'instance creation') -----
key: newKey value: newValue
"Answer an instance of me with the arguments as the key and value of
the association."
^ self basicNew key: newKey value: newValue.!
----- Method: Association>>= (in category 'comparing') -----
= anAssociation
^ super = anAssociation and: [value = anAssociation value]!
----- Method: Association>>byteEncode: (in category 'filter streaming') -----
byteEncode: aStream
aStream writeAssocation:self.!
----- Method: Association>>hash (in category 'comparing') -----
hash
"Hash is reimplemented because = is implemented."
^key hash bitXor: value hash.!
----- Method: Association>>isSpecialWriteBinding (in category 'testing') -----
isSpecialWriteBinding
"Return true if this variable binding is write protected, e.g., should not be accessed primitively but rather by sending #value: messages"
^false!
----- Method: Association>>isVariableBinding (in category 'testing') -----
isVariableBinding
"Return true if I represent a literal variable binding"
^true!
----- Method: Association>>key:value: (in category 'accessing') -----
key: aKey value: anObject
"Store the arguments as the variables of the receiver."
key _ aKey.
value _ anObject!
----- Method: Association>>objectForDataStream: (in category 'objects from disk') -----
objectForDataStream: refStrm
| dp |
"I am about to be written on an object file. If I am a known global, write a proxy that will hook up with the same resource in the destination system."
^ (Smalltalk associationAt: key ifAbsent: [nil]) == self
ifTrue: [dp _ DiskProxy global: #Smalltalk selector: #associationOrUndeclaredAt:
args: (Array with: key).
refStrm replace: self with: dp.
dp]
ifFalse: [self]!
----- Method: Association>>printOn: (in category 'printing') -----
printOn: aStream
super printOn: aStream.
aStream nextPutAll: '->'.
value printOn: aStream!
----- Method: Association>>propertyListOn: (in category 'printing') -----
propertyListOn: aStream
aStream write:key; print:'='; write:value.
!
----- Method: Association>>storeOn: (in category 'printing') -----
storeOn: aStream
"Store in the format (key->value)"
aStream nextPut: $(.
key storeOn: aStream.
aStream nextPutAll: '->'.
value storeOn: aStream.
aStream nextPut: $)!
----- Method: Association>>value (in category 'accessing') -----
value
"Answer the value of the receiver."
^value!
----- Method: Association>>value: (in category 'accessing') -----
value: anObject
"Store the argument, anObject, as the value of the receiver."
value _ anObject!
Association subclass: #WeakKeyAssociation
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Support'!
!WeakKeyAssociation commentStamp: '<historical>' prior: 0!
I am an association holding only weakly on my key.!
----- Method: WeakKeyAssociation>>< (in category 'comparing') -----
< aLookupKey
"Refer to the comment in Magnitude|<."
^self key < aLookupKey key!
----- Method: WeakKeyAssociation>>= (in category 'comparing') -----
= aLookupKey
self species = aLookupKey species
ifTrue: [^self key = aLookupKey key]
ifFalse: [^false]!
----- Method: WeakKeyAssociation>>hash (in category 'comparing') -----
hash
"Hash is reimplemented because = is implemented."
^self key hash!
----- Method: WeakKeyAssociation>>hashMappedBy: (in category 'comparing') -----
hashMappedBy: map
"Answer what my hash would be if oops changed according to map."
^self key hashMappedBy: map!
----- Method: WeakKeyAssociation>>identityHashMappedBy: (in category 'comparing') -----
identityHashMappedBy: map
"Answer what my hash would be if oops changed according to map."
^ self key identityHashMappedBy: map!
----- Method: WeakKeyAssociation>>key (in category 'accessing') -----
key
^key isNil
ifTrue:[nil]
ifFalse:[key at: 1]!
----- Method: WeakKeyAssociation>>key: (in category 'accessing') -----
key: aKey
key := WeakArray with: aKey!
----- Method: WeakKeyAssociation>>key:value: (in category 'accessing') -----
key: aKey value: anObject
key := WeakArray with: aKey.
value := anObject.!
----- Method: WeakKeyAssociation>>printOn: (in category 'printing') -----
printOn: aStream
self key printOn: aStream.
aStream nextPutAll: '->'.
self value printOn: aStream!
----- Method: WeakKeyAssociation>>storeOn: (in category 'printing') -----
storeOn: aStream
aStream
nextPut: $(;
nextPutAll: self class name;
nextPutAll:' key: '.
self key storeOn: aStream.
aStream nextPutAll: ' value: '.
self value storeOn: aStream.
aStream nextPut: $)!
----- Method: LookupKey class>>key: (in category 'instance creation') -----
key: aKey
"Answer an instance of me with the argument as the lookup up."
^self basicNew key: aKey!
----- Method: LookupKey>>< (in category 'comparing') -----
< aLookupKey
"Refer to the comment in Magnitude|<."
^key < aLookupKey key!
----- Method: LookupKey>>= (in category 'comparing') -----
= aLookupKey
self species = aLookupKey species
ifTrue: [^key = aLookupKey key]
ifFalse: [^false]!
----- Method: LookupKey>>beBindingOfType:announcing: (in category 'bindings') -----
beBindingOfType: aClass announcing: aBool
"Make the receiver a global binding of the given type"
| old new |
(Smalltalk associationAt: self key) == self
ifFalse:[^self error:'Not a global variable binding'].
self class == aClass ifTrue:[^self].
old _ self.
new _ aClass key: self key value: self value.
old become: new.
"NOTE: Now self == read-only (e.g., the new binding)"
^self recompileBindingsAnnouncing: aBool!
----- Method: LookupKey>>beReadOnlyBinding (in category 'bindings') -----
beReadOnlyBinding
"Make the receiver (a global read-write binding) be a read-only binding"
^self beReadOnlyBindingAnnouncing: true!
----- Method: LookupKey>>beReadOnlyBindingAnnouncing: (in category 'bindings') -----
beReadOnlyBindingAnnouncing: aBool
"Make the receiver (a global read-write binding) be a read-only binding"
^self beBindingOfType: ReadOnlyVariableBinding announcing: aBool!
----- Method: LookupKey>>beReadWriteBinding (in category 'bindings') -----
beReadWriteBinding
"Make the receiver (a global read-only binding) be a read-write binding"
^self beReadWriteBindingAnnouncing: true!
----- Method: LookupKey>>beReadWriteBindingAnnouncing: (in category 'bindings') -----
beReadWriteBindingAnnouncing: aBool
"Make the receiver (a global read-write binding) be a read-write binding"
^self beBindingOfType: Association announcing: aBool!
----- Method: LookupKey>>canAssign (in category 'accessing') -----
canAssign
^ true!
----- Method: LookupKey>>hash (in category 'comparing') -----
hash
"Hash is reimplemented because = is implemented."
^key hash!
----- Method: LookupKey>>hashMappedBy: (in category 'comparing') -----
hashMappedBy: map
"Answer what my hash would be if oops changed according to map."
^key hashMappedBy: map!
----- Method: LookupKey>>identityHashMappedBy: (in category 'comparing') -----
identityHashMappedBy: map
"Answer what my hash would be if oops changed according to map."
^ key identityHashMappedBy: map!
----- Method: LookupKey>>isVariableBinding (in category 'testing') -----
isVariableBinding
"Return true if I represent a literal variable binding"
^true!
----- Method: LookupKey>>key (in category 'accessing') -----
key
"Answer the lookup key of the receiver."
^key!
----- Method: LookupKey>>key: (in category 'accessing') -----
key: anObject
"Store the argument, anObject, as the lookup key of the receiver."
key _ anObject!
----- Method: LookupKey>>name (in category 'accessing') -----
name
^ self key isString
ifTrue: [self key]
ifFalse: [self key printString]!
----- Method: LookupKey>>printOn: (in category 'printing') -----
printOn: aStream
key printOn: aStream!
----- Method: LookupKey>>recompileBindingsAnnouncing: (in category 'bindings') -----
recompileBindingsAnnouncing: aBool
"Make the receiver (a global read-write binding) be a read-only binding"
aBool
ifTrue:
[Utilities informUserDuring:
[:bar |
(self systemNavigation allCallsOn: self) do:
[:mref |
bar value: 'Recompiling ' , mref asStringOrText.
mref actualClass recompile: mref methodSymbol]]]
ifFalse:
[(self systemNavigation allCallsOn: self)
do: [:mref | mref actualClass recompile: mref methodSymbol]]!
----- Method: LookupKey>>writeOnFilterStream: (in category 'filter streaming') -----
writeOnFilterStream: aStream
aStream write:key.!
LookupKey subclass: #ReadOnlyVariableBinding
instanceVariableNames: 'value'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Support'!
----- Method: ReadOnlyVariableBinding class>>key:value: (in category 'instance creation') -----
key: key value: aValue
^self new privateSetKey: key value: aValue!
----- Method: ReadOnlyVariableBinding>>canAssign (in category 'accessing') -----
canAssign
^ false!
----- Method: ReadOnlyVariableBinding>>isSpecialWriteBinding (in category 'testing') -----
isSpecialWriteBinding
"Return true if this variable binding is write protected, e.g., should not be accessed primitively but rather by sending #value: messages"
^true!
----- Method: ReadOnlyVariableBinding>>privateSetKey:value: (in category 'private') -----
privateSetKey: aKey value: aValue
key _ aKey.
value _ aValue!
----- Method: ReadOnlyVariableBinding>>value (in category 'accessing') -----
value
^value!
----- Method: ReadOnlyVariableBinding>>value: (in category 'accessing') -----
value: aValue
(AttemptToWriteReadOnlyGlobal signal: 'Cannot store into read-only bindings') == true ifTrue:[
value _ aValue.
].!
LookupKey weakSubclass: #WeakValueAssociation
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Support'!
!WeakValueAssociation commentStamp: '<historical>' prior: 0!
I am a lookup key (acting like an association but) holding only weakly on my value.!
----- Method: WeakValueAssociation class>>key:value: (in category 'instance creation') -----
key: anObject value: bObject
^ self new key: anObject value: bObject!
----- Method: WeakValueAssociation class>>new (in category 'as yet unclassified') -----
new
^ self new: 1!
----- Method: WeakValueAssociation>>key:value: (in category 'accessing') -----
key: aKey value: anObject
"Store the arguments as the variables of the receiver."
key _ aKey.
self value: anObject!
----- Method: WeakValueAssociation>>value (in category 'accessing') -----
value
^self at: 1!
----- Method: WeakValueAssociation>>value: (in category 'accessing') -----
value: anObject
"Store the argument, anObject, as the value of the receiver."
self at: 1 put: anObject!
Object subclass: #Collection
instanceVariableNames: ''
classVariableNames: 'MutexForPicking RandomForPicking'
poolDictionaries: ''
category: 'Collections-Abstract'!
!Collection commentStamp: '<historical>' prior: 0!
I am the abstract superclass of all classes that represent a group of elements.!
Collection subclass: #Bag
instanceVariableNames: 'contents'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Unordered'!
!Bag commentStamp: '<historical>' prior: 0!
I represent an unordered collection of possibly duplicate elements.
I store these elements in a dictionary, tallying up occurrences of equal objects. Because I store an occurrence only once, my clients should beware that objects they store will not necessarily be retrieved such that == is true. If the client cares, a subclass of me should be created.!
----- Method: Bag class>>contentsClass (in category 'instance creation') -----
contentsClass
^Dictionary!
----- Method: Bag class>>new (in category 'instance creation') -----
new
^ self new: 4!
----- Method: Bag class>>new: (in category 'instance creation') -----
new: nElements
^ super new setContents: (self contentsClass new: nElements)!
----- Method: Bag class>>newFrom: (in category 'instance creation') -----
newFrom: aCollection
"Answer an instance of me containing the same elements as aCollection."
^ self withAll: aCollection
"Examples:
Bag newFrom: {1. 2. 3. 3}
{1. 2. 3. 3} as: Bag
"!
----- Method: Bag>>= (in category 'comparing') -----
= aBag
"Two bags are equal if
(a) they are the same 'kind' of thing.
(b) they have the same size.
(c) each element occurs the same number of times in both of them"
(aBag isKindOf: Bag) ifFalse: [^false].
self size = aBag size ifFalse: [^false].
contents associationsDo: [:assoc|
(aBag occurrencesOf: assoc key) = assoc value
ifFalse: [^false]].
^true
!
----- Method: Bag>>add: (in category 'adding') -----
add: newObject
"Include newObject as one of the receiver's elements. Answer newObject."
^ self add: newObject withOccurrences: 1!
----- Method: Bag>>add:withOccurrences: (in category 'adding') -----
add: newObject withOccurrences: anInteger
"Add newObject anInteger times to the receiver. Answer newObject."
contents at: newObject put: (contents at: newObject ifAbsent: [0]) + anInteger.
^ newObject!
----- Method: Bag>>asBag (in category 'converting') -----
asBag
^ self!
----- Method: Bag>>asSet (in category 'converting') -----
asSet
"Answer a set with the elements of the receiver."
^ contents keys!
----- Method: Bag>>at: (in category 'accessing') -----
at: index
self errorNotKeyed!
----- Method: Bag>>at:put: (in category 'accessing') -----
at: index put: anObject
self errorNotKeyed!
----- Method: Bag>>copy (in category 'copying') -----
copy
^ self shallowCopy setContents: contents copy!
----- Method: Bag>>cumulativeCounts (in category 'accessing') -----
cumulativeCounts
"Answer with a collection of cumulative percents covered by elements so far."
| s n |
s _ self size / 100.0. n _ 0.
^ self sortedCounts asArray collect:
[:a | n _ n + a key. (n / s roundTo: 0.1) -> a value]!
----- Method: Bag>>do: (in category 'enumerating') -----
do: aBlock
"Refer to the comment in Collection|do:."
contents associationsDo: [:assoc | assoc value timesRepeat: [aBlock value: assoc key]]!
----- Method: Bag>>includes: (in category 'testing') -----
includes: anObject
"Refer to the comment in Collection|includes:."
^contents includesKey: anObject!
----- Method: Bag>>occurrencesOf: (in category 'testing') -----
occurrencesOf: anObject
"Refer to the comment in Collection|occurrencesOf:."
(self includes: anObject)
ifTrue: [^contents at: anObject]
ifFalse: [^0]!
----- Method: Bag>>remove:ifAbsent: (in category 'removing') -----
remove: oldObject ifAbsent: exceptionBlock
"Refer to the comment in Collection|remove:ifAbsent:."
| count |
count _ contents at: oldObject ifAbsent: [^ exceptionBlock value].
count = 1
ifTrue: [contents removeKey: oldObject]
ifFalse: [contents at: oldObject put: count - 1].
^ oldObject!
----- Method: Bag>>setContents: (in category 'private') -----
setContents: aDictionary
contents _ aDictionary!
----- Method: Bag>>size (in category 'accessing') -----
size
"Answer how many elements the receiver contains."
| tally |
tally _ 0.
contents do: [:each | tally _ tally + each].
^ tally!
----- Method: Bag>>sortedCounts (in category 'accessing') -----
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!
----- Method: Bag>>sortedElements (in category 'accessing') -----
sortedElements
"Answer with a collection of elements with counts, sorted by element."
| elements |
elements _ SortedCollection new.
contents associationsDo: [:assn | elements add: assn].
^elements!
Bag subclass: #IdentityBag
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Unordered'!
!IdentityBag commentStamp: '<historical>' prior: 0!
Like a Bag, except that items are compared with #== instead of #= .
See the comment of IdentitySet for more information.
!
----- Method: IdentityBag class>>contentsClass (in category 'instance creation') -----
contentsClass
^IdentityDictionary!
Collection subclass: #CharacterSet
instanceVariableNames: 'map'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Support'!
!CharacterSet commentStamp: '<historical>' prior: 0!
A set of characters. Lookups for inclusion are very fast.!
----- Method: CharacterSet class>>allCharacters (in category 'instance creation') -----
allCharacters
"return a set containing all characters"
| set |
set _ self empty.
0 to: 255 do: [ :ascii | set add: (Character value: ascii) ].
^set!
----- Method: CharacterSet class>>empty (in category 'instance creation') -----
empty
"return an empty set of characters"
^self new!
----- Method: CharacterSet class>>newFrom: (in category 'instance creation') -----
newFrom: aCollection
| newCollection |
newCollection _ self new.
newCollection addAll: aCollection.
^newCollection!
----- Method: CharacterSet class>>nonSeparators (in category 'instance creation') -----
nonSeparators
"return a set containing everything but the whitespace characters"
^self separators complement!
----- Method: CharacterSet class>>separators (in category 'instance creation') -----
separators
"return a set containing just the whitespace characters"
| set |
set _ self empty.
set addAll: Character separators.
^set!
----- Method: CharacterSet>>= (in category 'comparison') -----
= anObject
^self species == anObject species and: [
self byteArrayMap = anObject byteArrayMap ]!
----- Method: CharacterSet>>add: (in category 'collection ops') -----
add: aCharacter
map at: aCharacter asciiValue+1 put: 1.!
----- Method: CharacterSet>>byteArrayMap (in category 'private') -----
byteArrayMap
"return a ByteArray mapping each ascii value to a 1 if that ascii value is in the set, and a 0 if it isn't. Intended for use by primitives only"
^map!
----- Method: CharacterSet>>complement (in category 'conversion') -----
complement
"return a character set containing precisely the characters the receiver does not"
| set |
set _ CharacterSet allCharacters.
self do: [ :c | set remove: c ].
^set!
----- Method: CharacterSet>>do: (in category 'collection ops') -----
do: aBlock
"evaluate aBlock with each character in the set"
Character allByteCharacters do: [ :c |
(self includes: c) ifTrue: [ aBlock value: c ] ]
!
----- Method: CharacterSet>>hash (in category 'comparison') -----
hash
^self byteArrayMap hash!
----- Method: CharacterSet>>includes: (in category 'collection ops') -----
includes: aCharacter
^(map at: aCharacter asciiValue + 1) > 0!
----- Method: CharacterSet>>initialize (in category 'private') -----
initialize
map _ ByteArray new: 256 withAll: 0.!
----- Method: CharacterSet>>remove: (in category 'collection ops') -----
remove: aCharacter
map at: aCharacter asciiValue + 1 put: 0!
----- Method: CharacterSet>>species (in category 'comparison') -----
species
^CharacterSet!
----- Method: Collection class>>initialize (in category 'class initialization') -----
initialize
"Set up a Random number generator to be used by atRandom when the
user does not feel like creating his own Random generator."
RandomForPicking _ Random new.
MutexForPicking _ Semaphore forMutualExclusion.
Smalltalk addToStartUpList: Collection.
!
----- Method: Collection class>>mutexForPicking (in category 'private') -----
mutexForPicking
^ MutexForPicking!
----- Method: Collection class>>ofSize: (in category 'instance creation') -----
ofSize: n
"Create a new collection of size n with nil as its elements.
This method exists because OrderedCollection new: n creates an
empty collection, not one of size n."
^ self new: n!
----- Method: Collection class>>randomForPicking (in category 'private') -----
randomForPicking
^ RandomForPicking!
----- Method: Collection class>>startUp (in category 'private') -----
startUp
RandomForPicking seed: (Time totalSeconds) hash asFloat.
!
----- Method: Collection class>>with: (in category 'instance creation') -----
with: anObject
"Answer an instance of me containing anObject."
^ self new
add: anObject;
yourself!
----- Method: Collection class>>with:with: (in category 'instance creation') -----
with: firstObject with: secondObject
"Answer an instance of me containing the two arguments as elements."
^ self new
add: firstObject;
add: secondObject;
yourself!
----- Method: Collection class>>with:with:with: (in category 'instance creation') -----
with: firstObject with: secondObject with: thirdObject
"Answer an instance of me containing the three arguments as elements."
^ self new
add: firstObject;
add: secondObject;
add: thirdObject;
yourself!
----- Method: Collection class>>with:with:with:with: (in category 'instance creation') -----
with: firstObject with: secondObject with: thirdObject with: fourthObject
"Answer an instance of me, containing the four arguments as the elements."
^ self new
add: firstObject;
add: secondObject;
add: thirdObject;
add: fourthObject;
yourself!
----- Method: Collection class>>with:with:with:with:with: (in category 'instance creation') -----
with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject
"Answer an instance of me, containing the five arguments as the elements."
^ self new
add: firstObject;
add: secondObject;
add: thirdObject;
add: fourthObject;
add: fifthObject;
yourself!
----- Method: Collection class>>with:with:with:with:with:with: (in category 'instance creation') -----
with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject with: sixthObject
"Answer an instance of me, containing the six arguments as the elements."
^ self new
add: firstObject;
add: secondObject;
add: thirdObject;
add: fourthObject;
add: fifthObject;
add: sixthObject;
yourself!
----- Method: Collection class>>withAll: (in category 'instance creation') -----
withAll: aCollection
"Create a new collection containing all the elements from aCollection."
^ (self new: aCollection size)
addAll: aCollection;
yourself!
----- Method: Collection>>* (in category 'arithmetic') -----
* arg
^ arg adaptToCollection: self andSend: #*!
----- Method: Collection>>+ (in category 'arithmetic') -----
+ arg
^ arg adaptToCollection: self andSend: #+!
----- Method: Collection>>, (in category 'copying') -----
, aCollection
^self copy addAll: aCollection; yourself!
----- Method: Collection>>- (in category 'arithmetic') -----
- arg
^ arg adaptToCollection: self andSend: #-!
----- Method: Collection>>/ (in category 'arithmetic') -----
/ arg
^ arg adaptToCollection: self andSend: #/!
----- Method: Collection>>// (in category 'arithmetic') -----
// arg
^ arg adaptToCollection: self andSend: #//!
----- Method: Collection>>\\ (in category 'arithmetic') -----
\\ arg
^ arg adaptToCollection: self andSend: #\\!
----- Method: Collection>>abs (in category 'math functions') -----
abs
"Absolute value of all elements in the collection"
^ self collect: [:a | a abs]!
----- Method: Collection>>adaptToCollection:andSend: (in category 'adapting') -----
adaptToCollection: rcvr andSend: selector
"If I am involved in arithmetic with another Collection, return a Collection of
the results of each element combined with the scalar in that expression."
rcvr isSequenceable & self isSequenceable ifFalse:
[self error: 'Only sequenceable collections may be combined arithmetically'].
^ rcvr with: self collect:
[:rcvrElement :myElement | rcvrElement perform: selector with: myElement]!
----- Method: Collection>>adaptToComplex:andSend: (in category 'adapting') -----
adaptToComplex: rcvr andSend: selector
"If I am involved in arithmetic with a scalar, return a Collection of
the results of each element combined with the scalar in that expression."
^ self collect: [:element | rcvr perform: selector with: element]!
----- Method: Collection>>adaptToNumber:andSend: (in category 'adapting') -----
adaptToNumber: rcvr andSend: selector
"If I am involved in arithmetic with a scalar, return a Collection of
the results of each element combined with the scalar in that expression."
^ self collect: [:element | rcvr perform: selector with: element]!
----- Method: Collection>>adaptToPoint:andSend: (in category 'adapting') -----
adaptToPoint: rcvr andSend: selector
"If I am involved in arithmetic with a scalar, return a Collection of
the results of each element combined with the scalar in that expression."
^ self collect: [:element | rcvr perform: selector with: element]!
----- Method: Collection>>adaptToString:andSend: (in category 'adapting') -----
adaptToString: rcvr andSend: selector
"If I am involved in arithmetic with a String, convert it to a Number."
^ rcvr asNumber perform: selector with: self!
----- Method: Collection>>add: (in category 'adding') -----
add: newObject
"Include newObject as one of the receiver's elements. Answer newObject.
ArrayedCollections cannot respond to this message."
self subclassResponsibility!
----- Method: Collection>>add:withOccurrences: (in category 'adding') -----
add: newObject withOccurrences: anInteger
"Add newObject anInteger times to the receiver. Answer newObject."
anInteger timesRepeat: [self add: newObject].
^ newObject!
----- Method: Collection>>addAll: (in category 'adding') -----
addAll: aCollection
"Include all the elements of aCollection as the receiver's elements. Answer
aCollection. Actually, any object responding to #do: can be used as argument."
aCollection do: [:each | self add: each].
^ aCollection!
----- Method: Collection>>addIfNotPresent: (in category 'adding') -----
addIfNotPresent: anObject
"Include anObject as one of the receiver's elements, but only if there
is no such element already. Anwser anObject."
(self includes: anObject) ifFalse: [self add: anObject].
^ anObject!
----- Method: Collection>>allSatisfy: (in category 'enumerating') -----
allSatisfy: aBlock
"Evaluate aBlock with the elements of the receiver.
If aBlock returns false for any element return false.
Otherwise return true."
self do: [:each | (aBlock value: each) ifFalse: [^ false]].
^ true!
----- Method: Collection>>anyOne (in category 'accessing') -----
anyOne
"Answer a representative sample of the receiver. This method can
be helpful when needing to preinfer the nature of the contents of
semi-homogeneous collections."
self emptyCheck.
self do: [:each | ^ each]!
----- Method: Collection>>anySatisfy: (in category 'enumerating') -----
anySatisfy: aBlock
"Evaluate aBlock with the elements of the receiver.
If aBlock returns true for any element return true.
Otherwise return false."
self do: [:each | (aBlock value: each) ifTrue: [^ true]].
^ false!
----- Method: Collection>>arcCos (in category 'math functions') -----
arcCos
^self collect: [:each | each arcCos]!
----- Method: Collection>>arcSin (in category 'math functions') -----
arcSin
^self collect: [:each | each arcSin]!
----- Method: Collection>>arcTan (in category 'math functions') -----
arcTan
^self collect: [:each | each arcTan]!
----- Method: Collection>>asArray (in category 'converting') -----
asArray
"Answer an Array whose elements are the elements of the receiver.
Implementation note: Cannot use ''Array withAll: self'' as that only
works for SequenceableCollections which support the replacement
primitive."
| array index |
array _ Array new: self size.
index _ 0.
self do: [:each | array at: (index _ index + 1) put: each].
^ array!
----- Method: Collection>>asBag (in category 'converting') -----
asBag
"Answer a Bag whose elements are the elements of the receiver."
^ Bag withAll: self!
----- Method: Collection>>asByteArray (in category 'converting') -----
asByteArray
"Answer a ByteArray whose elements are the elements of the receiver.
Implementation note: Cannot use ''ByteArray withAll: self'' as that only
works for SequenceableCollections which support the replacement
primitive."
| array index |
array _ ByteArray new: self size.
index _ 0.
self do: [:each | array at: (index _ index + 1) put: each].
^ array!
----- Method: Collection>>asCharacterSet (in category 'converting') -----
asCharacterSet
"Answer a CharacterSet whose elements are the unique elements of the receiver.
The reciever should only contain characters."
^ CharacterSet newFrom: self!
----- Method: Collection>>asIdentitySet (in category 'converting') -----
asIdentitySet
^(IdentitySet new: self size) addAll: self; yourself!
----- Method: Collection>>asIdentitySkipList (in category 'converting') -----
asIdentitySkipList
"Answer a IdentitySkipList whose elements are the elements of the
receiver. The sort order is the default less than or equal."
^ self as: IdentitySkipList!
----- Method: Collection>>asOrderedCollection (in category 'converting') -----
asOrderedCollection
"Answer an OrderedCollection whose elements are the elements of the
receiver. The order in which elements are added depends on the order
in which the receiver enumerates its elements. In the case of unordered
collections, the ordering is not necessarily the same for multiple
requests for the conversion."
^ self as: OrderedCollection!
----- Method: Collection>>asSet (in category 'converting') -----
asSet
"Answer a Set whose elements are the unique elements of the receiver."
^ Set withAll: self!
----- Method: Collection>>asSkipList (in category 'converting') -----
asSkipList
"Answer a SkipList whose elements are the elements of the
receiver. The sort order is the default less than or equal."
^ self as: SkipList!
----- Method: Collection>>asSkipList: (in category 'converting') -----
asSkipList: aSortBlock
"Answer a SkipList whose elements are the elements of the
receiver. The sort order is defined by the argument, aSortBlock."
| skipList |
skipList _ SortedCollection new: self size.
skipList sortBlock: aSortBlock.
skipList addAll: self.
^ skipList!
----- Method: Collection>>asSortedArray (in category 'converting') -----
asSortedArray
"Return a copy of the receiver in sorted order, as an Array. 6/10/96 sw"
^ self asSortedCollection asArray!
----- Method: Collection>>asSortedCollection (in category 'converting') -----
asSortedCollection
"Answer a SortedCollection whose elements are the elements of the
receiver. The sort order is the default less than or equal."
^ self as: SortedCollection!
----- Method: Collection>>asSortedCollection: (in category 'converting') -----
asSortedCollection: aSortBlock
"Answer a SortedCollection whose elements are the elements of the
receiver. The sort order is defined by the argument, aSortBlock."
| aSortedCollection |
aSortedCollection _ SortedCollection new: self size.
aSortedCollection sortBlock: aSortBlock.
aSortedCollection addAll: self.
^ aSortedCollection!
----- Method: Collection>>associationsDo: (in category '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!
----- Method: Collection>>atRandom (in category 'accessing') -----
atRandom
"Answer a random element of the receiver. 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."
^ self class mutexForPicking critical: [
self atRandom: self class randomForPicking ]
"Examples:
#('one' 'or' 'the' 'other') atRandom
(1 to: 10) atRandom
'Just pick one of these letters at random' atRandom
#(3 7 4 9 21) asSet atRandom (just to show it also works for Sets)
"!
----- Method: Collection>>average (in category 'math functions') -----
average
^ self sum / self size!
----- Method: Collection>>capacity (in category 'accessing') -----
capacity
"Answer the current capacity of the receiver."
^ self size!
----- Method: Collection>>ceiling (in category 'math functions') -----
ceiling
^ self collect: [:a | a ceiling]!
----- Method: Collection>>collect: (in category 'enumerating') -----
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
the new collection."
| newCollection |
newCollection _ self species new.
self do: [:each | newCollection add: (aBlock value: each)].
^ newCollection!
----- Method: Collection>>collect:thenDo: (in category 'enumerating') -----
collect: collectBlock thenDo: doBlock
"Utility method to improve readability."
^ (self collect: collectBlock) do: doBlock!
----- Method: Collection>>collect:thenSelect: (in category 'enumerating') -----
collect: collectBlock thenSelect: selectBlock
"Utility method to improve readability."
^ (self collect: collectBlock) select: selectBlock!
----- Method: Collection>>contents (in category 'filter streaming') -----
contents
^ self!
----- Method: Collection>>copyWith: (in category 'copying') -----
copyWith: newElement
"Answer a new collection with newElement added (as last
element if sequenceable)."
^ self copy
add: newElement;
yourself!
----- Method: Collection>>copyWithDependent: (in category 'copying') -----
copyWithDependent: newElement
"Answer a new collection with newElement added (as last
element if sequenceable)."
^self copyWith: newElement!
----- Method: Collection>>copyWithout: (in category 'copying') -----
copyWithout: oldElement
"Answer a copy of the receiver that does not contain any
elements equal to oldElement."
^ self reject: [:each | each = oldElement]
"Examples:
'fred the bear' copyWithout: $e
#(2 3 4 5 5 6) copyWithout: 5
"!
----- Method: Collection>>copyWithoutAll: (in category 'copying') -----
copyWithoutAll: aCollection
"Answer a copy of the receiver that does not contain any elements
equal to those in aCollection."
^ self reject: [:each | aCollection includes: each]!
----- Method: Collection>>cos (in category 'math functions') -----
cos
^self collect: [:each | each cos]!
----- Method: Collection>>count: (in category 'enumerating') -----
count: aBlock
"Evaluate aBlock with each of the receiver's elements as the argument.
Answer the number of elements that answered true."
| sum |
sum _ 0.
self do: [:each | (aBlock value: each) ifTrue: [sum _ sum + 1]].
^ sum!
----- Method: Collection>>degreeCos (in category 'math functions') -----
degreeCos
^self collect: [:each | each degreeCos]!
----- Method: Collection>>degreeSin (in category 'math functions') -----
degreeSin
^self collect: [:each | each degreeSin]!
----- Method: Collection>>detect: (in category 'enumerating') -----
detect: aBlock
"Evaluate aBlock with each of the receiver's elements as the argument.
Answer the first element for which aBlock evaluates to true."
^ self detect: aBlock ifNone: [self errorNotFound: aBlock]!
----- Method: Collection>>detect:ifNone: (in category 'enumerating') -----
detect: aBlock ifNone: exceptionBlock
"Evaluate aBlock with each of the receiver's elements as the argument.
Answer the first element for which aBlock evaluates to true. If none
evaluate to true, then evaluate the argument, exceptionBlock."
self do: [:each | (aBlock value: each) ifTrue: [^ each]].
^ exceptionBlock value!
----- Method: Collection>>detectMax: (in category 'enumerating') -----
detectMax: aBlock
"Evaluate aBlock with each of the receiver's elements as the argument.
Answer the element for which aBlock evaluates to the highest magnitude.
If collection empty, return nil. This method might also be called elect:."
| maxElement maxValue val |
self do: [:each |
maxValue == nil
ifFalse: [
(val _ aBlock value: each) > maxValue ifTrue: [
maxElement _ each.
maxValue _ val]]
ifTrue: ["first element"
maxElement _ each.
maxValue _ aBlock value: each].
"Note that there is no way to get the first element that works
for all kinds of Collections. Must test every one."].
^ maxElement!
----- Method: Collection>>detectMin: (in category 'enumerating') -----
detectMin: aBlock
"Evaluate aBlock with each of the receiver's elements as the argument.
Answer the element for which aBlock evaluates to the lowest number.
If collection empty, return nil."
| minElement minValue val |
self do: [:each |
minValue == nil
ifFalse: [
(val _ aBlock value: each) < minValue ifTrue: [
minElement _ each.
minValue _ val]]
ifTrue: ["first element"
minElement _ each.
minValue _ aBlock value: each].
"Note that there is no way to get the first element that works
for all kinds of Collections. Must test every one."].
^ minElement!
----- Method: Collection>>detectSum: (in category 'enumerating') -----
detectSum: aBlock
"Evaluate aBlock with each of the receiver's elements as the argument.
Return the sum of the answers."
| sum |
sum _ 0.
self do: [:each |
sum _ (aBlock value: each) + sum].
^ sum!
----- Method: Collection>>difference: (in category 'enumerating') -----
difference: aCollection
"Answer the set theoretic difference of two collections."
^ self reject: [:each | aCollection includes: each]!
----- Method: Collection>>do: (in category 'enumerating') -----
do: aBlock
"Evaluate aBlock with each of the receiver's elements as the argument."
self subclassResponsibility!
----- Method: Collection>>do:separatedBy: (in category 'enumerating') -----
do: elementBlock separatedBy: separatorBlock
"Evaluate the elementBlock for all elements in the receiver,
and evaluate the separatorBlock between."
| beforeFirst |
beforeFirst _ true.
self do:
[:each |
beforeFirst
ifTrue: [beforeFirst _ false]
ifFalse: [separatorBlock value].
elementBlock value: each]!
----- Method: Collection>>do:without: (in category 'enumerating') -----
do: aBlock without: anItem
"Enumerate all elements in the receiver.
Execute aBlock for those elements that are not equal to the given item"
^ self do: [:each | anItem = each ifFalse: [aBlock value: each]]!
----- Method: Collection>>emptyCheck (in category 'private') -----
emptyCheck
self isEmpty ifTrue: [self errorEmptyCollection]!
----- Method: Collection>>errorEmptyCollection (in category 'private') -----
errorEmptyCollection
self error: 'this collection is empty'!
----- Method: Collection>>errorNoMatch (in category 'private') -----
errorNoMatch
self error: 'collection sizes do not match'!
----- Method: Collection>>errorNotFound: (in category 'private') -----
errorNotFound: anObject
"Actually, this should raise a special Exception not just an error."
self error: 'Object is not in the collection.'!
----- Method: Collection>>errorNotKeyed (in category 'private') -----
errorNotKeyed
self error: ('Instances of {1} do not respond to keyed accessing messages.' translated format: {self class name})
!
----- Method: Collection>>exp (in category 'math functions') -----
exp
^self collect: [:each | each exp]!
----- Method: Collection>>explorerContents (in category 'enumerating') -----
explorerContents
^self explorerContentsWithIndexCollect: [:value :index |
ObjectExplorerWrapper
with: value
name: index printString
model: self]!
----- Method: Collection>>explorerContentsWithIndexCollect: (in category 'enumerating') -----
explorerContentsWithIndexCollect: twoArgBlock
^ self asOrderedCollection withIndexCollect: twoArgBlock
!
----- Method: Collection>>flattenOnStream: (in category 'filter streaming') -----
flattenOnStream: aStream
^ aStream writeCollection: self!
----- Method: Collection>>floor (in category 'math functions') -----
floor
^ self collect: [:a | a floor]!
----- Method: Collection>>groupBy:having: (in category 'enumerating') -----
groupBy: keyBlock having: selectBlock
"Like in SQL operation - Split the recievers contents into collections of
elements for which keyBlock returns the same results, and return those
collections allowed by selectBlock. keyBlock should return an Integer."
| result key |
result _ PluggableDictionary integerDictionary.
self do:
[:e |
key _ keyBlock value: e.
(result includesKey: key)
ifFalse: [result at: key put: OrderedCollection new].
(result at: key)
add: e].
^ result _ result select: selectBlock!
----- Method: Collection>>hash (in category 'comparing') -----
hash
"Answer an integer hash value for the receiver such that,
-- the hash value of an unchanged object is constant over time, and
-- two equal objects have equal hash values"
| hash |
hash _ self species hash.
self size <= 10 ifTrue:
[self do: [:elem | hash _ hash bitXor: elem hash]].
^hash bitXor: self size hash!
----- Method: Collection>>identityIncludes: (in category 'testing') -----
identityIncludes: anObject
"Answer whether anObject is one of the receiver's elements."
self do: [:each | anObject == each ifTrue: [^true]].
^false!
----- Method: Collection>>ifEmpty: (in category 'testing') -----
ifEmpty: aBlock
"Evaluate the block if I'm empty"
^ self isEmpty ifTrue: aBlock!
----- Method: Collection>>ifEmpty:ifNotEmpty: (in category 'testing') -----
ifEmpty: emptyBlock ifNotEmpty: notEmptyBlock
"Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise"
" If the notEmptyBlock has an argument, eval with the receiver as its argument"
^ self isEmpty ifTrue: emptyBlock ifFalse: [notEmptyBlock valueWithPossibleArgument: self]!
----- Method: Collection>>ifEmpty:ifNotEmptyDo: (in category 'testing') -----
ifEmpty: emptyBlock ifNotEmptyDo: notEmptyBlock
"Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise"
"Evaluate the notEmptyBlock with the receiver as its argument"
^ self isEmpty ifTrue: emptyBlock ifFalse: [notEmptyBlock value: self]!
----- Method: Collection>>ifNotEmpty: (in category 'testing') -----
ifNotEmpty: aBlock
"Evaluate the given block unless the receiver is empty.
If the block has an argument, eval with the receiver as its argument,
but it might be better to use ifNotEmptyDo: to make the code easier to
understand"
^self isEmpty ifFalse: [aBlock valueWithPossibleArgument: self].
!
----- Method: Collection>>ifNotEmpty:ifEmpty: (in category 'testing') -----
ifNotEmpty: notEmptyBlock ifEmpty: emptyBlock
"Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise
If the notEmptyBlock has an argument, eval with the receiver as its argument"
^ self isEmpty ifFalse: [notEmptyBlock valueWithPossibleArgument: self] ifTrue: emptyBlock!
----- Method: Collection>>ifNotEmptyDo: (in category 'testing') -----
ifNotEmptyDo: aBlock
"Evaluate the given block with the receiver as its argument."
^self isEmpty ifFalse: [aBlock value: self].
!
----- Method: Collection>>ifNotEmptyDo:ifEmpty: (in category 'testing') -----
ifNotEmptyDo: notEmptyBlock ifEmpty: emptyBlock
"Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise
Evaluate the notEmptyBlock with the receiver as its argument"
^ self isEmpty ifFalse: [notEmptyBlock value: self] ifTrue: emptyBlock!
----- Method: Collection>>includes: (in category 'testing') -----
includes: anObject
"Answer whether anObject is one of the receiver's elements."
^ self anySatisfy: [:each | each = anObject]!
----- Method: Collection>>includesAllOf: (in category 'testing') -----
includesAllOf: aCollection
"Answer whether all the elements of aCollection are in the receiver."
aCollection do: [:elem | (self includes: elem) ifFalse: [^ false]].
^ true!
----- Method: Collection>>includesAnyOf: (in category 'testing') -----
includesAnyOf: aCollection
"Answer whether any element of aCollection is one of the receiver's elements."
aCollection do: [:elem | (self includes: elem) ifTrue: [^ true]].
^ false!
----- Method: Collection>>includesSubstringAnywhere: (in category 'testing') -----
includesSubstringAnywhere: testString
"Answer whether the receiver includes, anywhere in its nested structure, a string that has testString as a substring"
self do:
[:element |
(element isString)
ifTrue:
[(element includesSubString: testString) ifTrue: [^ true]].
(element isCollection)
ifTrue:
[(element includesSubstringAnywhere: testString) ifTrue: [^ true]]].
^ false
"#(first (second third) ((allSentMessages ('Elvis' includes:)))) includesSubstringAnywhere: 'lvi'"!
----- Method: Collection>>inject:into: (in category 'enumerating') -----
inject: thisValue into: binaryBlock
"Accumulate a running value associated with evaluating the argument,
binaryBlock, with the current value of the argument, thisValue, and the
receiver as block arguments. For instance, to sum the numeric elements
of a collection, aCollection inject: 0 into: [:subTotal :next | subTotal +
next]."
| nextValue |
nextValue _ thisValue.
self do: [:each | nextValue _ binaryBlock value: nextValue value: each].
^nextValue!
----- Method: Collection>>intersection: (in category 'enumerating') -----
intersection: aCollection
"Answer the set theoretic intersection of two collections."
^ self select: [:each | aCollection includes: each]!
----- Method: Collection>>isCollection (in category 'testing') -----
isCollection
"Return true if the receiver is some sort of Collection and responds to basic collection messages such as #size and #do:"
^true!
----- Method: Collection>>isEmpty (in category 'testing') -----
isEmpty
"Answer whether the receiver contains any elements."
^self size = 0!
----- Method: Collection>>isEmptyOrNil (in category 'testing') -----
isEmptyOrNil
"Answer whether the receiver contains any elements, or is nil. Useful in numerous situations where one wishes the same reaction to an empty collection or to nil"
^ self isEmpty!
----- Method: Collection>>isSequenceable (in category 'testing') -----
isSequenceable
^ false!
----- Method: Collection>>isZero (in category 'testing') -----
isZero
"Answer whether the receiver is zero"
^ false!
----- Method: Collection>>ln (in category 'math functions') -----
ln
^self collect: [:each | each ln]!
----- Method: Collection>>log (in category 'math functions') -----
log
^ self collect: [:each | each log]!
----- Method: Collection>>max (in category 'math functions') -----
max
^ self inject: self anyOne into: [:max :each | max max: each]!
----- Method: Collection>>median (in category 'math functions') -----
median
^ self asSortedCollection median!
----- Method: Collection>>min (in category 'math functions') -----
min
^ self inject: self anyOne into: [:min :each | min min: each]!
----- Method: Collection>>negated (in category 'math functions') -----
negated
"Negated value of all elements in the collection"
^ self collect: [:a | a negated]!
----- Method: Collection>>noneSatisfy: (in category 'enumerating') -----
noneSatisfy: aBlock
"Evaluate aBlock with the elements of the receiver.
If aBlock returns false for all elements return true.
Otherwise return false"
self do: [:item | (aBlock value: item) ifTrue: [^ false]].
^ true!
----- Method: Collection>>notEmpty (in category 'testing') -----
notEmpty
"Answer whether the receiver contains any elements."
^ self isEmpty not!
----- Method: Collection>>occurrencesOf: (in category 'testing') -----
occurrencesOf: anObject
"Answer how many of the receiver's elements are equal to anObject."
| tally |
tally _ 0.
self do: [:each | anObject = each ifTrue: [tally _ tally + 1]].
^tally!
----- Method: Collection>>printElementsOn: (in category 'printing') -----
printElementsOn: aStream
aStream nextPut: $(.
self do: [:element | aStream print: element; space].
self isEmpty ifFalse: [aStream skip: -1].
aStream nextPut: $)!
----- Method: Collection>>printNameOn: (in category 'printing') -----
printNameOn: aStream
super printOn: aStream!
----- Method: Collection>>printOn: (in category 'printing') -----
printOn: aStream
"Append a sequence of characters that identify the receiver to aStream."
self printNameOn: aStream.
self printElementsOn: aStream!
----- Method: Collection>>raisedTo: (in category 'arithmetic') -----
raisedTo: arg
^ arg adaptToCollection: self andSend: #raisedTo:!
----- Method: Collection>>range (in category 'math functions') -----
range
^ self max - self min!
----- Method: Collection>>reciprocal (in category 'math functions') -----
reciprocal
"Return the reciever full of reciprocated elements"
^ self collect: [:a | a reciprocal]!
----- Method: Collection>>reject: (in category 'enumerating') -----
reject: aBlock
"Evaluate aBlock with each of the receiver's elements as the argument.
Collect into a new collection like the receiver only those elements for
which aBlock evaluates to false. Answer the new collection."
^self select: [:element | (aBlock value: element) == false]!
----- Method: Collection>>reject:thenDo: (in category 'enumerating') -----
reject: rejectBlock thenDo: doBlock
"Utility method to improve readability."
^ (self reject: rejectBlock) do: doBlock!
----- Method: Collection>>remove: (in category 'removing') -----
remove: oldObject
"Remove oldObject from the receiver's elements. Answer oldObject
unless no element is equal to oldObject, in which case, raise an error.
ArrayedCollections cannot respond to this message."
^ self remove: oldObject ifAbsent: [self errorNotFound: oldObject]!
----- Method: Collection>>remove:ifAbsent: (in category 'removing') -----
remove: oldObject ifAbsent: anExceptionBlock
"Remove oldObject from 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. ArrayedCollections cannot
respond to this message."
self subclassResponsibility!
----- Method: Collection>>removeAll: (in category 'removing') -----
removeAll: aCollection
"Remove each element of aCollection from the receiver. If successful for
each, answer aCollection. Otherwise create an error notification.
ArrayedCollections cannot respond to this message."
aCollection do: [:each | self remove: each].
^ aCollection!
----- Method: Collection>>removeAllFoundIn: (in category 'removing') -----
removeAllFoundIn: aCollection
"Remove each element of aCollection which is present in the receiver
from the receiver. Answer aCollection. No error is raised if an element
isn't found. ArrayedCollections cannot respond to this message."
aCollection do: [:each | self remove: each ifAbsent: []].
^ aCollection!
----- Method: Collection>>removeAllSuchThat: (in category 'removing') -----
removeAllSuchThat: aBlock
"Evaluate aBlock for each element and remove all that elements from
the receiver for that aBlock evaluates to true. Use a copy to enumerate
collections whose order changes when an element is removed (i.e. Sets)."
self copy do: [:each | (aBlock value: each) ifTrue: [self remove: each]]!
----- Method: Collection>>roundTo: (in category 'math functions') -----
roundTo: quantum
^self collect: [ :ea | ea roundTo: quantum ]!
----- Method: Collection>>rounded (in category 'math functions') -----
rounded
^ self collect: [:a | a rounded]!
----- Method: Collection>>select: (in category 'enumerating') -----
select: aBlock
"Evaluate aBlock with each of the receiver's elements as the argument.
Collect into a new collection like the receiver, only those elements for
which aBlock evaluates to true. Answer the new collection."
| newCollection |
newCollection _ self species new.
self do: [:each | (aBlock value: each) ifTrue: [newCollection add: each]].
^newCollection!
----- Method: Collection>>select:thenCollect: (in category 'enumerating') -----
select: selectBlock thenCollect: collectBlock
"Utility method to improve readability."
^ (self select: selectBlock) collect: collectBlock!
----- Method: Collection>>select:thenDo: (in category 'enumerating') -----
select: selectBlock thenDo: doBlock
"Utility method to improve readability."
^ (self select: selectBlock) do: doBlock!
----- Method: Collection>>sign (in category 'math functions') -----
sign
^self collect: [:each | each sign]!
----- Method: Collection>>sin (in category 'math functions') -----
sin
^self collect: [:each | each sin]!
----- Method: Collection>>size (in category 'accessing') -----
size
"Answer how many elements the receiver contains."
| tally |
tally _ 0.
self do: [:each | tally _ tally + 1].
^ tally!
----- Method: Collection>>sqrt (in category 'math functions') -----
sqrt
^ self collect: [:each | each sqrt]!
----- Method: Collection>>squared (in category 'math functions') -----
squared
^ self collect: [:each | each * each]!
----- Method: Collection>>storeOn: (in category 'printing') -----
storeOn: aStream
"Refer to the comment in Object|storeOn:."
| noneYet |
aStream nextPutAll: '(('.
aStream nextPutAll: self class name.
aStream nextPutAll: ' new)'.
noneYet _ true.
self do:
[:each |
noneYet
ifTrue: [noneYet _ false]
ifFalse: [aStream nextPut: $;].
aStream nextPutAll: ' add: '.
aStream store: each].
noneYet ifFalse: [aStream nextPutAll: '; yourself'].
aStream nextPut: $)!
----- Method: Collection>>sum (in category 'math functions') -----
sum
"This is implemented using a variant of the normal inject:into: pattern.
The reason for this is that it is not known whether we're in the normal
number line, i.e. whether 0 is a good initial value for the sum.
Consider a collection of measurement objects, 0 would be the unitless
value and would not be appropriate to add with the unit-ed objects."
| sum sample |
sample _ self anyOne.
sum _ self inject: sample into: [:accum :each | accum + each].
^ sum - sample!
----- Method: Collection>>tan (in category 'math functions') -----
tan
^self collect: [:each | each tan]!
----- Method: Collection>>toBraceStack: (in category 'private') -----
toBraceStack: itsSize
"Push receiver's elements onto the stack of thisContext sender. Error if receiver does
not have itsSize elements or if receiver is unordered.
Do not call directly: this is called by {a. b} _ ... constructs."
self size ~= itsSize ifTrue:
[self error: 'Trying to store ', self size printString,
' values into ', itsSize printString, ' variables.'].
thisContext sender push: itsSize fromIndexable: self!
----- Method: Collection>>truncated (in category 'math functions') -----
truncated
^ self collect: [:a | a truncated]!
----- Method: Collection>>union: (in category 'enumerating') -----
union: aCollection
"Answer the set theoretic union of two collections."
^ self asSet addAll: aCollection; yourself!
----- Method: Collection>>write: (in category 'filter streaming') -----
write: anObject
^ self add: anObject!
Collection subclass: #Matrix
instanceVariableNames: 'nrows ncols contents'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Unordered'!
!Matrix commentStamp: '<historical>' prior: 0!
I represent a two-dimensional array, rather like Array2D.
There are three main differences between me and Array2D:
(1) Array2D inherits from ArrayedCollection, but isn't one. A lot of things that should work
do not work in consequence of this.
(2) Array2D uses "at: column at: row" index order, which means that nothing you write using
it is likely to work either. I use the almost universal "at: row at: column" order, so it is
much easier to adapt code from other languages without going doolally.
(3) Array2D lets you specify the class of the underlying collection, I don't.
Structure:
nrows : a non-negative integer saying how many rows there are.
ncols : a non-negative integer saying how many columns there are.
contents : an Array holding the elements in row-major order. That is, for a 2x3 array
the contents are (11 12 13 21 22 23). Array2D uses column major order.
You can specify the class of 'contents' when you create a new Array2D,
but Matrix always gives you an Array.
There is a reason for this. In strongly typed languages like Haskell and Clean,
'unboxed arrays' save you both space AND time. But in Squeak, while
WordArray and FloatArray and so on do save space, it costs time to use them.
A LOT of time. I've measured aFloatArray sum running nearly twice as slow as
anArray sum. The reason is that whenever you fetch an element from an Array,
that's all that happens, but when you fetch an element from aFloatArray, a whole
new Float gets allocated to hold the value. This takes time and churns memory.
So the paradox is that if you want fast numerical stuff, DON'T use unboxed arrays!!
Another reason for always insisting on an Array is that letting it be something
else would make things like #, and #,, rather more complicated. Always using Array
is the simplest thing that could possibly work, and it works rather well.
I was trying to patch Array2D to make more things work, but just couldn't get my head
around the subscript order. That's why I made Matrix.
Element-wise matrix arithmetic works; you can freely mix matrices and numbers but
don't try to mix matrices and arrays (yet).
Matrix multiplication, using the symbol +* (derived from APL's +.x), works between
(Matrix or Array) +* (Matrix or Array). Don't try to use a number as an argument of +*.
Matrix * Number and Number * Matrix work fine, so you don't need +* with numbers.
Still to come: oodles of stuff. Gaussian elimination maybe, other stuff probably not.
!
----- Method: Matrix class>>column: (in category 'instance creation') -----
column: aCollection
"Should this be called #fromColumn:?"
^self rows: aCollection size columns: 1 contents: aCollection asArray shallowCopy!
----- Method: Matrix class>>diagonal: (in category 'instance creation') -----
diagonal: aCollection
|r i|
r _ self zeros: aCollection size.
i _ 0.
aCollection do: [:each | i _ i+1. r at: i at: i put: each].
^r!
----- Method: Matrix class>>identity: (in category 'instance creation') -----
identity: n
|r|
r _ self zeros: n.
1 to: n do: [:i | r at: i at: i put: 1].
^r!
----- Method: Matrix class>>new: (in category 'instance creation') -----
new: dim
"Answer a dim*dim matrix. Is this an abuse of #new:? The argument is NOT a size."
^self rows: dim columns: dim!
----- Method: Matrix class>>new:element: (in category 'instance creation') -----
new: dim element: element
"Answer a dim*dim matrix with all elements set to element.
Is this an abuse of #new:? The argument is NOT a size."
^self rows: dim columns: dim element: element!
----- Method: Matrix class>>new:tabulate: (in category 'instance creation') -----
new: dim tabulate: aBlock
"Answer a dim*dim matrix where it at: i at: j is aBlock value: i value: j."
^self rows: dim columns: dim tabulate: aBlock!
----- Method: Matrix class>>ones: (in category 'instance creation') -----
ones: n
^self new: n element: 1
!
----- Method: Matrix class>>row: (in category 'instance creation') -----
row: aCollection
"Should this be called #fromRow:?"
^self rows: 1 columns: aCollection size contents: aCollection asArray shallowCopy!
----- Method: Matrix class>>rows:columns: (in category 'instance creation') -----
rows: rows columns: columns
^self rows: rows columns: columns contents: (Array new: rows*columns)!
----- Method: Matrix class>>rows:columns:contents: (in category 'private') -----
rows: rows columns: columns contents: contents
^self new rows: rows columns: columns contents: contents!
----- Method: Matrix class>>rows:columns:element: (in category 'instance creation') -----
rows: rows columns: columns element: element
^self rows: rows columns: columns
contents: ((Array new: rows*columns) atAllPut: element; yourself)!
----- Method: Matrix class>>rows:columns:tabulate: (in category 'instance creation') -----
rows: rows columns: columns tabulate: aBlock
"Answer a new Matrix of the given dimensions where
result at: i at: j is aBlock value: i value: j"
|a i|
a _ Array new: rows*columns.
i _ 0.
1 to: rows do: [:row |
1 to: columns do: [:column |
a at: (i _ i+1) put: (aBlock value: row value: column)]].
^self rows: rows columns: columns contents: a
!
----- Method: Matrix class>>zeros: (in category 'instance creation') -----
zeros: n
^self new: n element: 0!
----- Method: Matrix>>+* (in category 'arithmetic') -----
+* aCollection
"Premultiply aCollection by self. aCollection should be an Array or Matrix.
The name of this method is APL's +.x squished into Smalltalk syntax."
^aCollection preMultiplyByMatrix: self
!
----- Method: Matrix>>, (in category 'copying') -----
, aMatrix
"Answer a new matrix having the same number of rows as the receiver and aMatrix,
its columns being the columns of the receiver followed by the columns of aMatrix."
|newCont newCols anArray oldCols a b c|
self assert: [nrows = aMatrix rowCount].
newCont _ Array new: self size + aMatrix size.
anArray _ aMatrix privateContents.
oldCols _ aMatrix columnCount.
newCols _ ncols + oldCols.
a _ b _ c _ 1.
1 to: nrows do: [:r |
newCont replaceFrom: a to: a+ncols-1 with: contents startingAt: b.
newCont replaceFrom: a+ncols to: a+newCols-1 with: anArray startingAt: c.
a _ a + newCols.
b _ b + ncols.
c _ c + oldCols].
^self class rows: nrows columns: newCols contents: newCont
!
----- Method: Matrix>>,, (in category 'copying') -----
,, aMatrix
"Answer a new matrix having the same number of columns as the receiver and aMatrix,
its rows being the rows of the receiver followed by the rows of aMatrix."
self assert: [ncols = aMatrix columnCount].
^self class rows: nrows + aMatrix rowCount columns: ncols
contents: contents , aMatrix privateContents
!
----- Method: Matrix>>= (in category 'comparing') -----
= aMatrix
^aMatrix class == self class and: [
aMatrix rowCount = nrows and: [
aMatrix columnCount = ncols and: [
aMatrix privateContents = contents]]]!
----- Method: Matrix>>add: (in category 'adding') -----
add: newObject
self shouldNotImplement!
----- Method: Matrix>>anyOne (in category 'accessing') -----
anyOne
^contents anyOne!
----- Method: Matrix>>asArray (in category 'converting') -----
asArray
^contents shallowCopy!
----- Method: Matrix>>asBag (in category 'converting') -----
asBag
^contents asBag!
----- Method: Matrix>>asByteArray (in category 'converting') -----
asByteArray
^contents asByteArray!
----- Method: Matrix>>asCharacterSet (in category 'converting') -----
asCharacterSet
^contents asCharacterSet!
----- Method: Matrix>>asFloatArray (in category 'converting') -----
asFloatArray
^contents asFloatArray!
----- Method: Matrix>>asIdentitySet (in category 'converting') -----
asIdentitySet
^contents asIdentitySet!
----- Method: Matrix>>asIntegerArray (in category 'converting') -----
asIntegerArray
^contents asIntegerArray!
----- Method: Matrix>>asOrderedCollection (in category 'converting') -----
asOrderedCollection
^contents asOrderedCollection!
----- Method: Matrix>>asSet (in category 'converting') -----
asSet
^contents asSet!
----- Method: Matrix>>asSortedArray (in category 'converting') -----
asSortedArray
^contents asSortedArray!
----- Method: Matrix>>asSortedCollection (in category 'converting') -----
asSortedCollection
^contents asSortedCollection!
----- Method: Matrix>>asSortedCollection: (in category 'converting') -----
asSortedCollection: aBlock
^contents asSortedCollection: aBlock!
----- Method: Matrix>>asWordArray (in category 'converting') -----
asWordArray
^contents asWordArray!
----- Method: Matrix>>at:at: (in category 'accessing') -----
at: row at: column
^contents at: (self indexForRow: row andColumn: column)!
----- Method: Matrix>>at:at:ifInvalid: (in category 'accessing') -----
at: r at: c ifInvalid: v
"If r,c is a valid index for this matrix, answer the corresponding element.
Otherwise, answer v."
(r between: 1 and: nrows) ifFalse: [^v].
(c between: 1 and: ncols) ifFalse: [^v].
^contents at: (r-1)*ncols + c
!
----- Method: Matrix>>at:at:incrementBy: (in category 'accessing') -----
at: row at: column incrementBy: value
"Array2D>>at:at:add: was the origin of this method, but in Smalltalk add:
generally suggests adding an element to a collection, not doing a sum.
This method, and SequenceableCollection>>at:incrementBy: that supports
it, have been renamed to reveal their intention more clearly."
^contents at: (self indexForRow: row andColumn: column) incrementBy: value!
----- Method: Matrix>>at:at:put: (in category 'accessing') -----
at: row at: column put: value
^contents at: (self indexForRow: row andColumn: column) put: value!
----- Method: Matrix>>atAllPut: (in category 'accessing') -----
atAllPut: value
contents atAllPut: value!
----- Method: Matrix>>atColumn: (in category 'accessing rows/columns') -----
atColumn: column
|p|
p _ (self indexForRow: 1 andColumn: column)-ncols.
^(1 to: nrows) collect: [:row | contents at: (p _ p+ncols)]
!
----- Method: Matrix>>atColumn:put: (in category 'accessing rows/columns') -----
atColumn: column put: aCollection
|p|
aCollection size = nrows ifFalse: [self error: 'wrong column size'].
p _ (self indexForRow: 1 andColumn: column)-ncols.
aCollection do: [:each | contents at: (p _ p+ncols) put: each].
^aCollection
!
----- Method: Matrix>>atRandom (in category 'accessing') -----
atRandom
^contents atRandom
!
----- Method: Matrix>>atRandom: (in category 'accessing') -----
atRandom: aGenerator
^contents atRandom: aGenerator!
----- Method: Matrix>>atRow: (in category 'accessing rows/columns') -----
atRow: row
(row between: 1 and: nrows)
ifFalse: [self error: '1st subscript out of range'].
^contents copyFrom: (row-1)*ncols+1 to: row*ncols!
----- Method: Matrix>>atRow:put: (in category 'accessing rows/columns') -----
atRow: row put: aCollection
|p|
aCollection size = ncols ifFalse: [self error: 'wrong row size'].
p _ (self indexForRow: row andColumn: 1)-1.
aCollection do: [:each | contents at: (p _ p+1) put: each].
^aCollection!
----- Method: Matrix>>atRows:columns: (in category 'accessing submatrices') -----
atRows: rs columns: cs
"Answer a Matrix obtained by slicing the receiver.
rs and cs should be sequenceable collections of positive integers."
^self class rows: rs size columns: cs size tabulate: [:r :c |
self at: (rs at: r) at: (cs at: c)]!
----- Method: Matrix>>atRows:to:columns:to: (in category 'accessing submatrices') -----
atRows: r1 to: r2 columns: c1 to: c2
"Answer a submatrix [r1..r2][c1..c2] of the receiver."
|rd cd|
rd _ r1 - 1.
cd _ c1 - 1.
^self class rows: r2-rd columns: c2-cd tabulate: [:r :c| self at: r+rd at: c+cd]
!
----- Method: Matrix>>atRows:to:columns:to:ifInvalid: (in category 'accessing submatrices') -----
atRows: r1 to: r2 columns: c1 to: c2 ifInvalid: element
"Answer a submatrix [r1..r2][c1..c2] of the receiver.
Portions of the result outside the bounds of the original matrix
are filled in with element."
|rd cd|
rd _ r1 - 1.
cd _ c1 - 1.
^self class rows: r2-rd columns: c2-cd tabulate: [:r :c| self at: r+rd at: c+cd ifInvalid: element]
!
----- Method: Matrix>>atRows:to:columns:to:put: (in category 'accessing submatrices') -----
atRows: r1 to: r2 columns: c1 to: c2 put: aMatrix
"Set the [r1..r2][c1..c2] submatrix of the receiver
from the [1..r2-r1+1][1..c2-c1+1] submatrix of aMatrix.
As long as aMatrix responds to at:at: and accepts arguments in the range shown,
we don't care if it is bigger or even if it is a Matrix at all."
|rd cd|
rd _ r1 - 1.
cd _ c1 - 1.
r1 to: r2 do: [:r |
c1 to: c2 do: [:c |
self at: r at: c put: (aMatrix at: r-rd at: c-cd)]].
^aMatrix
!
----- Method: Matrix>>collect: (in category 'enumerating') -----
collect: aBlock
"Answer a new matrix with transformed elements; transformations should be independent."
^self class rows: nrows columns: ncols contents: (contents collect: aBlock)!
----- Method: Matrix>>columnCount (in category 'accessing') -----
columnCount
^ncols!
----- Method: Matrix>>copy (in category 'copying') -----
copy
^self class rows: nrows columns: ncols contents: contents copy!
----- Method: Matrix>>diagonal (in category 'accessing rows/columns') -----
diagonal
"Answer (1 to: (nrows min: ncols)) collect: [:i | self at: i at: i]"
|i|
i _ ncols negated.
^(1 to: (nrows min: ncols)) collect: [:j | contents at: (i _ i + ncols + 1)]!
----- Method: Matrix>>difference: (in category 'enumerating') -----
difference: aCollection
"Union is in because the result is always a Set.
Difference and intersection are out because the result is like the receiver,
and with irregular seleection that cannot be."
self shouldNotImplement!
----- Method: Matrix>>do: (in category 'enumerating') -----
do: aBlock
"Pass elements to aBlock one at a time in row-major order."
contents do: aBlock!
----- Method: Matrix>>hash (in category 'comparing') -----
hash
"I'm really not sure what would be a good hash function here.
The essential thing is that it must be compatible with #=, and
this satisfies that requirement."
^contents hash!
----- Method: Matrix>>identityIncludes: (in category 'testing') -----
identityIncludes: anObject
^contents identityIncludes: anObject!
----- Method: Matrix>>identityIndexOf: (in category 'accessing') -----
identityIndexOf: anElement
^self identityIndexOf: anElement ifAbsent: [0 at 0]
!
----- Method: Matrix>>identityIndexOf:ifAbsent: (in category 'accessing') -----
identityIndexOf: anElement ifAbsent: anExceptionBlock
^self rowAndColumnForIndex:
(contents identityIndexOf: anElement ifAbsent: [^anExceptionBlock value])
!
----- Method: Matrix>>includes: (in category 'testing') -----
includes: anObject
^contents includes: anObject!
----- Method: Matrix>>includesAllOf: (in category 'testing') -----
includesAllOf: aCollection
^contents includesAllOf: aCollection!
----- Method: Matrix>>includesAnyOf: (in category 'testing') -----
includesAnyOf: aCollection
^contents includesAnyOf: aCollection!
----- Method: Matrix>>indexForRow:andColumn: (in category 'private') -----
indexForRow: row andColumn: column
(row between: 1 and: nrows)
ifFalse: [self error: '1st subscript out of range'].
(column between: 1 and: ncols)
ifFalse: [self error: '2nd subscript out of range'].
^(row-1) * ncols + column!
----- Method: Matrix>>indexOf: (in category 'accessing') -----
indexOf: anElement
"If there are integers r, c such that (self at: r at: c) = anElement,
answer some such r at c, otherwise answer 0 at 0. This kind of perverse
result is provided by analogy with SequenceableCollection>>indexOf:.
The order in which the receiver are searched is UNSPECIFIED except
that it is the same as the order used by #indexOf:ifAbsent: and #readStream."
^self indexOf: anElement ifAbsent: [0 at 0]
!
----- Method: Matrix>>indexOf:ifAbsent: (in category 'accessing') -----
indexOf: anElement ifAbsent: anExceptionBlock
"If there are integers r, c such that (self at: r at: c) = anElement,
answer some such r at c, otherwise answer the result of anExceptionBlock."
^self rowAndColumnForIndex:
(contents indexOf: anElement ifAbsent: [^anExceptionBlock value])
!
----- Method: Matrix>>indicesCollect: (in category 'enumerating') -----
indicesCollect: aBlock
|r i|
r _ Array new: nrows * ncols.
i _ 0.
1 to: nrows do: [:row |
1 to: ncols do: [:column |
r at: (i _ i+1) put: (aBlock value: row value: column)]].
^self class rows: nrows columns: ncols contents: r!
----- Method: Matrix>>indicesDo: (in category 'enumerating') -----
indicesDo: aBlock
1 to: nrows do: [:row |
1 to: ncols do: [:column |
aBlock value: row value: column]].!
----- Method: Matrix>>indicesInject:into: (in category 'enumerating') -----
indicesInject: start into: aBlock
|current|
current _ start.
1 to: nrows do: [:row |
1 to: ncols do: [:column |
current _ aBlock value: current value: row value: column]].
^current!
----- Method: Matrix>>intersection: (in category 'enumerating') -----
intersection: aCollection
"Union is in because the result is always a Set.
Difference and intersection are out because the result is like the receiver,
and with irregular seleection that cannot be."
self shouldNotImplement!
----- Method: Matrix>>isSequenceable (in category 'testing') -----
isSequenceable
"LIE so that arithmetic on matrices will work.
What matters for arithmetic is not that there should be random indexing
but that the structure should be stable and independent of the values of
the elements. #isSequenceable is simply the wrong question to ask."
^true!
----- Method: Matrix>>occurrencesOf: (in category 'testing') -----
occurrencesOf: anObject
^contents occurrencesOf: anObject!
----- Method: Matrix>>preMultiplyByArray: (in category 'arithmetic') -----
preMultiplyByArray: a
"Answer a +* self where a is an Array."
nrows = 1 ifFalse: [self error: 'dimensions do not conform'].
^Matrix rows: a size columns: ncols tabulate: [:row :col |
(a at: row) * (contents at: col)]
!
----- Method: Matrix>>preMultiplyByMatrix: (in category 'arithmetic') -----
preMultiplyByMatrix: m
"Answer m +* self where m is a Matrix."
|s|
nrows = m columnCount ifFalse: [self error: 'dimensions do not conform'].
^Matrix rows: m rowCount columns: ncols tabulate: [:row :col |
s _ 0.
1 to: nrows do: [:k | s _ (m at: row at: k) * (self at: k at: col) + s].
s]!
----- Method: Matrix>>privateContents (in category 'private') -----
privateContents
"Only used in #, #,, and #= so far.
It used to be called #contents, but that clashes with Collection>>contents."
^contents!
----- Method: Matrix>>readStream (in category 'converting') -----
readStream
"Answer a ReadStream that returns all the elements of the receiver
in some UNSPECIFIED order."
^ReadStream on: contents!
----- Method: Matrix>>reject: (in category 'enumerating') -----
reject: aBlock
self shouldNotImplement!
----- Method: Matrix>>remove:ifAbsent: (in category 'removing') -----
remove: anObject ifAbsent: anExceptionBlock
self shouldNotImplement!
----- Method: Matrix>>replaceAll:with: (in category 'accessing') -----
replaceAll: oldObject with: newObject
contents replaceAll: oldObject with: newObject!
----- Method: Matrix>>rowAndColumnForIndex: (in category 'private') -----
rowAndColumnForIndex: index
|t|
t _ index - 1.
^(t // ncols + 1)@(t \\ ncols + 1)!
----- Method: Matrix>>rowCount (in category 'accessing') -----
rowCount
^nrows!
----- Method: Matrix>>rows:columns:contents: (in category 'private') -----
rows: rows columns: columns contents: anArray
self assert: [rows isInteger and: [rows >= 0]].
self assert: [columns isInteger and: [columns >= 0]].
self assert: [rows * columns = anArray size].
nrows _ rows.
ncols _ columns.
contents _ anArray.
^self!
----- Method: Matrix>>select: (in category 'enumerating') -----
select: aBlock
self shouldNotImplement!
----- Method: Matrix>>shallowCopy (in category 'copying') -----
shallowCopy
^self class rows: nrows columns: ncols contents: contents shallowCopy!
----- Method: Matrix>>shuffled (in category 'copying') -----
shuffled
^self class rows: nrows columns: ncols contents: (contents shuffled)!
----- Method: Matrix>>shuffledBy: (in category 'copying') -----
shuffledBy: aRandom
^self class rows: nrows columns: ncols contents: (contents shuffledBy: aRandom)!
----- Method: Matrix>>size (in category 'accessing') -----
size
^contents size!
----- Method: Matrix>>storeOn: (in category 'printing') -----
storeOn: aStream
aStream nextPut: $(; nextPutAll: self class name;
nextPutAll: ' rows: '; store: nrows;
nextPutAll: ' columns: '; store: ncols;
nextPutAll: ' contents: '; store: contents;
nextPut: $)!
----- Method: Matrix>>swap:at:with:at: (in category 'accessing') -----
swap: r1 at: c1 with: r2 at: c2
contents swap: (self indexForRow: r1 andColumn: c1)
with: (self indexForRow: r2 andColumn: c2)!
----- Method: Matrix>>swapColumn:withColumn: (in category 'accessing rows/columns') -----
swapColumn: anIndex withColumn: anotherIndex
|a b|
a _ self indexForRow: 1 andColumn: anIndex.
b _ self indexForRow: 1 andColumn: anotherIndex.
nrows timesRepeat: [
contents swap: a with: b.
a _ a + ncols.
b _ b + ncols].
!
----- Method: Matrix>>swapRow:withRow: (in category 'accessing rows/columns') -----
swapRow: anIndex withRow: anotherIndex
|a b|
a _ self indexForRow: anIndex andColumn: 1.
b _ self indexForRow: anotherIndex andColumn: 1.
ncols timesRepeat: [
contents swap: a with: b.
a _ a + 1.
b _ b + 1].
!
----- Method: Matrix>>transposed (in category 'accessing rows/columns') -----
transposed
self assert: [nrows = ncols].
^self indicesCollect: [:row :column | self at: column at: row]!
----- Method: Matrix>>with:collect: (in category 'enumerating') -----
with: aCollection collect: aBlock
"aCollection must support #at:at: and be at least as large as the receiver."
^self withIndicesCollect: [:each :row :column |
aBlock value: each value: (aCollection at: row at: column)]
!
----- Method: Matrix>>with:do: (in category 'enumerating') -----
with: aCollection do: aBlock
"aCollection must support #at:at: and be at least as large as the receiver."
self withIndicesDo: [:each :row :column |
aBlock value: each value: (aCollection at: row at: column)].
!
----- Method: Matrix>>with:inject:into: (in category 'enumerating') -----
with: aCollection inject: startingValue into: aBlock
"aCollection must support #at:at: and be at least as large as the receiver."
^self withIndicesInject: startingValue into: [:value :each :row :column |
aBlock value: value value: each value: (aCollection at: row at: column)]!
----- Method: Matrix>>withIndicesCollect: (in category 'enumerating') -----
withIndicesCollect: aBlock
|i r|
i _ 0.
r _ contents shallowCopy.
1 to: nrows do: [:row |
1 to: ncols do: [:column |
i _ i+1.
r at: i put: (aBlock value: (r at: i) value: row value: column)]].
^self class rows: nrows columns: ncols contents: r
!
----- Method: Matrix>>withIndicesDo: (in category 'enumerating') -----
withIndicesDo: aBlock
|i|
i _ 0.
1 to: nrows do: [:row |
1 to: ncols do: [:column |
aBlock value: (contents at: (i _ i+1)) value: row value: column]].
!
----- Method: Matrix>>withIndicesInject:into: (in category 'enumerating') -----
withIndicesInject: start into: aBlock
|i current|
i _ 0.
current _ start.
1 to: nrows do: [:row |
1 to: ncols do: [:column |
current _ aBlock value: current value: (contents at: (i _ i+1))
value: row value: column]].
^current!
Collection subclass: #SequenceableCollection
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Abstract'!
!SequenceableCollection commentStamp: '<historical>' prior: 0!
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 subclass: #ArrayedCollection
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Abstract'!
!ArrayedCollection commentStamp: '<historical>' prior: 0!
I am an abstract collection of elements with a fixed range of integers (from 1 to n>=0) as external keys.!
ArrayedCollection variableSubclass: #Array
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Arrayed'!
!Array commentStamp: '<historical>' prior: 0!
I present an ArrayedCollection whose elements are objects.!
----- Method: Array class>>braceStream: (in category 'brace support') -----
braceStream: nElements
"This method is used in compilation of brace constructs.
It MUST NOT be deleted or altered."
^ WriteStream basicNew braceArray: (self new: nElements)
!
----- Method: Array class>>braceWith: (in category 'brace support') -----
braceWith: a
"This method is used in compilation of brace constructs.
It MUST NOT be deleted or altered."
| array |
array _ self new: 1.
array at: 1 put: a.
^ array!
----- Method: Array class>>braceWith:with: (in category 'brace support') -----
braceWith: a with: b
"This method is used in compilation of brace constructs.
It MUST NOT be deleted or altered."
| array |
array _ self new: 2.
array at: 1 put: a.
array at: 2 put: b.
^ array!
----- Method: Array class>>braceWith:with:with: (in category 'brace support') -----
braceWith: a with: b with: c
"This method is used in compilation of brace constructs.
It MUST NOT be deleted or altered."
| array |
array _ self new: 3.
array at: 1 put: a.
array at: 2 put: b.
array at: 3 put: c.
^ array!
----- Method: Array class>>braceWith:with:with:with: (in category 'brace support') -----
braceWith: a with: b with: c with: d
"This method is used in compilation of brace constructs.
It MUST NOT be deleted or altered."
| array |
array _ self new: 4.
array at: 1 put: a.
array at: 2 put: b.
array at: 3 put: c.
array at: 4 put: d.
^ array!
----- Method: Array class>>braceWithNone (in category 'brace support') -----
braceWithNone
"This method is used in compilation of brace constructs.
It MUST NOT be deleted or altered."
^ self new: 0!
----- Method: Array class>>ccg:emitLoadFor:from:on: (in category 'plugin generation') -----
ccg: cg emitLoadFor: aString from: anInteger on: aStream
cg emitLoad: aString asIntPtrFrom: anInteger on: aStream!
----- Method: Array class>>ccg:prolog:expr:index: (in category 'plugin generation') -----
ccg: cg prolog: aBlock expr: aString index: anInteger
^cg
ccgLoad: aBlock
expr: aString
asIntPtrFrom: anInteger
andThen: (cg ccgValBlock: 'isIndexable')!
----- Method: Array class>>ccgDeclareCForVar: (in category 'plugin generation') -----
ccgDeclareCForVar: aSymbolOrString
^'int *', aSymbolOrString!
----- Method: Array class>>new: (in category 'instance creation') -----
new: sizeRequested
"Answer an instance of this class with the number of indexable
variables specified by the argument, sizeRequested.
This is a shortcut (direct call of primitive, no #initialize, for performance"
<primitive: 71> "This method runs primitively if successful"
^ self basicNew: sizeRequested "Exceptional conditions will be handled in basicNew:"
!
----- Method: Array>>+* (in category 'arithmetic') -----
+* aCollection
"Premultiply aCollection by self. aCollection should be an Array or Matrix.
The name of this method is APL's +.x squished into Smalltalk syntax."
^aCollection preMultiplyByArray: self
!
----- Method: Array>>asArray (in category 'converting') -----
asArray
"Answer with the receiver itself."
^ self!
----- Method: Array>>atWrap: (in category 'accessing') -----
atWrap: index
"Optimized to go through the primitive if possible"
<primitive: 60>
^ self at: index - 1 \\ self size + 1!
----- Method: Array>>atWrap:put: (in category 'accessing') -----
atWrap: index put: anObject
"Optimized to go through the primitive if possible"
<primitive: 61>
^ self at: index - 1 \\ self size + 1 put: anObject!
----- Method: Array>>byteEncode: (in category 'filter streaming') -----
byteEncode:aStream
aStream writeArray:self.
!
----- Method: Array>>copy (in category 'copying') -----
copy
^ self clone.
!
----- Method: Array>>copyWithDependent: (in category 'copying') -----
copyWithDependent: newElement
self size = 0 ifTrue:[^DependentsArray with: newElement].
^self copyWith: newElement!
----- Method: Array>>elementsExchangeIdentityWith: (in category 'converting') -----
elementsExchangeIdentityWith: otherArray
"This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. At the same time, all pointers to the elements of otherArray are replaced by pointers to the corresponding elements of this array. The identityHashes remain with the pointers rather than with the objects so that objects in hashed structures should still be properly indexed after the mutation."
<primitive: 128>
otherArray class == Array ifFalse: [^ self error: 'arg must be array'].
self size = otherArray size ifFalse: [^ self error: 'arrays must be same size'].
(self anySatisfy: [:obj | obj class == SmallInteger]) ifTrue: [^ self error: 'can''t become SmallIntegers'].
(otherArray anySatisfy: [:obj | obj class == SmallInteger]) ifTrue: [^ self error: 'can''t become SmallIntegers'].
self with: otherArray do:[:a :b| a == b ifTrue:[^self error:'can''t become yourself']].
"Must have failed because not enough space in forwarding table (see ObjectMemory-prepareForwardingTableForBecoming:with:twoWay:). Do GC and try again only once"
(Smalltalk bytesLeft: true) = Smalltalk primitiveGarbageCollect
ifTrue: [^ self primitiveFailed].
^ self elementsExchangeIdentityWith: otherArray!
----- Method: Array>>elementsForwardIdentityTo: (in category 'converting') -----
elementsForwardIdentityTo: otherArray
"This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. The identityHashes remain with the pointers rather than with the objects so that the objects in this array should still be properly indexed in any existing hashed structures after the mutation."
<primitive: 72>
self primitiveFailed!
----- Method: Array>>elementsForwardIdentityTo:copyHash: (in category 'converting') -----
elementsForwardIdentityTo: otherArray copyHash: copyHash
"This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. The identityHashes remain with the pointers rather than with the objects so that the objects in this array should still be properly indexed in any existing hashed structures after the mutation."
<primitive: 249>
self primitiveFailed!
----- Method: Array>>evalStrings (in category 'converting') -----
evalStrings
"Allows you to construct literal arrays.
#(true false nil '5 at 6' 'Set new' '''text string''') evalStrings
gives an array with true, false, nil, a Point, a Set, and a String
instead of just a bunch of Symbols"
| it |
^ self collect: [:each |
it _ each.
each == #true ifTrue: [it _ true].
each == #false ifTrue: [it _ false].
each == #nil ifTrue: [it _ nil].
(each isString and:[each isSymbol not]) ifTrue: [
it _ Compiler evaluate: each].
each class == Array ifTrue: [it _ it evalStrings].
it]!
----- Method: Array>>hasLiteral: (in category 'private') -----
hasLiteral: literal
"Answer true if literal is identical to any literal in this array, even
if imbedded in further array structure. This method is only intended
for private use by CompiledMethod hasLiteralSymbol:"
| lit |
1 to: self size do:
[:index |
(lit _ self at: index) == literal ifTrue: [^ true].
(lit class == Array and: [lit hasLiteral: literal]) ifTrue: [^ true]].
^ false!
----- Method: Array>>hasLiteralSuchThat: (in category 'private') -----
hasLiteralSuchThat: litBlock
"Answer true if litBlock returns true for any literal in this array, even if imbedded in further array structure. This method is only intended for private use by CompiledMethod hasLiteralSuchThat:"
| lit |
1 to: self size do:
[:index | lit _ self at: index.
(litBlock value: lit) ifTrue: [^ true].
(lit class == Array and: [lit hasLiteralSuchThat: litBlock]) ifTrue: [^ true]].
^false!
----- Method: Array>>hashMappedBy: (in category 'comparing') -----
hashMappedBy: map
"Answer what my hash would be if oops changed according to map."
self size = 0 ifTrue: [^self hash].
^(self first hashMappedBy: map) + (self last hashMappedBy: map)!
----- Method: Array>>isArray (in category 'testing') -----
isArray
^true!
----- Method: Array>>isLiteral (in category 'testing') -----
isLiteral
^ self allSatisfy: [:each | each isLiteral]!
----- Method: Array>>literalEqual: (in category 'comparing') -----
literalEqual: other
self class == other class ifFalse: [^ false].
self size = other size ifFalse: [^ false].
self with: other do: [:e1 :e2 |
(e1 literalEqual: e2) ifFalse: [^ false]].
^ true!
----- Method: Array>>literalStringsDo: (in category 'translating') -----
literalStringsDo: aBlock
"Assuming the receiver receiver is a literal, evaluate aBlock with all Strings (but not Symbols) within it."
self do: [:each | each literalStringsDo: aBlock]!
----- Method: Array>>objectForDataStream: (in category 'file in/out') -----
objectForDataStream: refStrm
| dp |
"I am about to be written on an object file. If I am one of two shared global arrays, write a proxy instead."
self == (TextConstants at: #DefaultTabsArray) ifTrue: [
dp _ DiskProxy global: #TextConstants selector: #at: args: #(DefaultTabsArray).
refStrm replace: self with: dp.
^ dp].
self == (TextConstants at: #DefaultMarginTabsArray) ifTrue: [
dp _ DiskProxy global: #TextConstants selector: #at: args: #(DefaultMarginTabsArray).
refStrm replace: self with: dp.
^ dp].
^ super objectForDataStream: refStrm!
----- Method: Array>>preMultiplyByArray: (in category 'arithmetic') -----
preMultiplyByArray: a
"Answer a+*self where a is an Array. Arrays are always understood as column vectors,
so an n element Array is an n*1 Array. This multiplication is legal iff self size = 1."
self size = 1 ifFalse: [self error: 'dimensions do not conform'].
^a * self first!
----- Method: Array>>preMultiplyByMatrix: (in category 'arithmetic') -----
preMultiplyByMatrix: m
"Answer m+*self where m is a Matrix."
|s|
m columnCount = self size ifFalse: [self error: 'dimensions do not conform'].
^(1 to: m rowCount) collect: [:row |
s _ 0.
1 to: self size do: [:k | s _ (m at: row at: k) * (self at: k) + s].
s]!
----- Method: Array>>printOn: (in category 'printing') -----
printOn: aStream
aStream nextPut: $#.
self printElementsOn: aStream!
----- Method: Array>>replaceFrom:to:with:startingAt: (in category '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!
----- Method: Array>>shallowCopy (in category 'copying') -----
shallowCopy
^ self clone.
!
----- Method: Array>>storeOn: (in category 'printing') -----
storeOn: aStream
"Use the literal form if possible."
self isLiteral
ifTrue:
[aStream nextPut: $#; nextPut: $(.
self do:
[:element |
element printOn: aStream.
aStream space].
aStream nextPut: $)]
ifFalse: [super storeOn: aStream]!
----- Method: Array>>storeOnStream: (in category 'filter streaming') -----
storeOnStream:aStream
self isLiteral ifTrue: [super storeOnStream:aStream] ifFalse:[aStream writeCollection:self].
!
----- Method: Array>>translatedNoop (in category 'translating') -----
translatedNoop
"This is correspondence gettext_noop() in gettext."
^ self!
Array weakSubclass: #WeakArray
instanceVariableNames: ''
classVariableNames: 'FinalizationDependents FinalizationLock FinalizationProcess FinalizationSemaphore IsFinalizationSupported'
poolDictionaries: ''
category: 'Collections-Weak'!
!WeakArray commentStamp: '<historical>' prior: 0!
WeakArray is an array which holds only weakly on its elements. This means whenever an object is only referenced by instances of WeakArray it will be garbage collected.!
----- Method: WeakArray class>>addWeakDependent: (in category 'accessing') -----
addWeakDependent: anObject
| finished index weakDependent |
self isFinalizationSupported ifFalse:[^self].
FinalizationLock critical:[
finished := false.
index := 0.
[index := index + 1.
finished not and:[index <= FinalizationDependents size]] whileTrue:[
weakDependent := FinalizationDependents at: index.
weakDependent isNil ifTrue:[
FinalizationDependents at: index put: anObject.
finished := true.
].
].
finished ifFalse:[
"Grow linearly"
FinalizationDependents := FinalizationDependents, (WeakArray new: 10).
FinalizationDependents at: index put: anObject.
].
] ifError:[:msg :rcvr| rcvr error: msg].!
----- Method: WeakArray class>>finalizationProcess (in category 'private') -----
finalizationProcess
[true] whileTrue:
[FinalizationSemaphore wait.
FinalizationLock critical:
[FinalizationDependents do:
[:weakDependent |
weakDependent ifNotNil:
[weakDependent finalizeValues.
"***Following statement is required to keep weakDependent
from holding onto its value as garbage.***"
weakDependent _ nil]]]
ifError:
[:msg :rcvr | rcvr error: msg].
].
!
----- Method: WeakArray class>>initialize (in category 'class initialization') -----
initialize
"WeakArray initialize"
"Do we need to initialize specialObjectsArray?"
Smalltalk specialObjectsArray size < 42
ifTrue:[Smalltalk recreateSpecialObjectsArray].
Smalltalk addToStartUpList: self.
self restartFinalizationProcess.!
----- Method: WeakArray class>>isFinalizationSupported (in category 'accessing') -----
isFinalizationSupported
"Check if this VM supports the finalization mechanism"
| tempObject |
IsFinalizationSupported ifNotNil:[^IsFinalizationSupported].
tempObject _ WeakArray new: 1.
"Check if the class format 4 is correctly understood by the VM.
If the weak class support is not installed then the VM will report
any weak class as containing 32bit words - not pointers"
(tempObject at: 1) = nil
ifFalse:[^IsFinalizationSupported _false].
"Check if objects are correctly freed"
self pvtCreateTemporaryObjectIn: tempObject.
Smalltalk garbageCollect.
^IsFinalizationSupported _ (tempObject at: 1) == nil!
----- Method: WeakArray class>>pvtCreateTemporaryObjectIn: (in category 'private') -----
pvtCreateTemporaryObjectIn: tempObject
"We have to create the temporary object in a separate stack frame"
tempObject at: 1 put: Object new!
----- Method: WeakArray class>>removeWeakDependent: (in category 'accessing') -----
removeWeakDependent: anObject
self isFinalizationSupported ifFalse:[^self].
FinalizationLock critical:[
1 to: FinalizationDependents size do:[:i|
((FinalizationDependents at: i) == anObject) ifTrue:[
FinalizationDependents at: i put: nil.
].
].
] ifError:[:msg :rcvr| rcvr error: msg].!
----- Method: WeakArray class>>restartFinalizationProcess (in category 'private') -----
restartFinalizationProcess
"kill any old process, just in case"
FinalizationProcess
ifNotNil: [FinalizationProcess terminate.
FinalizationProcess := nil].
"Check if Finalization is supported by this VM"
IsFinalizationSupported := nil.
self isFinalizationSupported
ifFalse: [^ self].
FinalizationSemaphore := Smalltalk specialObjectsArray at: 42.
FinalizationDependents ifNil: [FinalizationDependents := WeakArray new: 10].
FinalizationLock := Semaphore forMutualExclusion.
FinalizationProcess := [self finalizationProcess]
forkAt: Processor userInterruptPriority!
----- Method: WeakArray class>>runningFinalizationProcess (in category 'accessing') -----
runningFinalizationProcess
"Answer the FinalizationProcess I am running, if any"
^FinalizationProcess!
----- Method: WeakArray class>>startUp: (in category 'system startup') -----
startUp: resuming
resuming ifFalse: [ ^self ].
self restartFinalizationProcess.!
----- Method: ArrayedCollection class>>ccg:generateCoerceToOopFrom:on: (in category 'plugin generation') -----
ccg: cg generateCoerceToOopFrom: aNode on: aStream
self instSize > 0 ifTrue:
[self error: 'cannot auto-coerce arrays with named instance variables'].
cg generateCoerceToObjectFromPtr: aNode on: aStream!
----- Method: ArrayedCollection class>>ccg:generateCoerceToValueFrom:on: (in category 'plugin generation') -----
ccg: cg generateCoerceToValueFrom: aNode on: aStream
cg
generateCoerceToPtr: (self ccgDeclareCForVar: '')
fromObject: aNode on: aStream!
----- Method: ArrayedCollection class>>new (in category 'instance creation') -----
new
"Answer a new instance of me, with size = 0."
^self new: 0!
----- Method: ArrayedCollection class>>new:withAll: (in category 'instance creation') -----
new: size withAll: value
"Answer an instance of me, with number of elements equal to size, each
of which refers to the argument, value."
^(self new: size) atAllPut: value!
----- Method: ArrayedCollection class>>newFrom: (in category 'instance creation') -----
newFrom: aCollection
"Answer an instance of me containing the same elements as aCollection."
| newArray |
newArray _ self new: aCollection size.
1 to: aCollection size do: [:i | newArray at: i put: (aCollection at: i)].
^ newArray
" Array newFrom: {1. 2. 3}
{1. 2. 3} as: Array
{1. 2. 3} as: ByteArray
{$c. $h. $r} as: String
{$c. $h. $r} as: Text
"!
----- Method: ArrayedCollection class>>newFromStream: (in category 'instance creation') -----
newFromStream: s
"Only meant for my subclasses that are raw bits and word-like. For quick unpack form the disk."
| len |
self isPointers | self isWords not ifTrue: [^ super newFromStream: s].
"super may cause an error, but will not be called."
s next = 16r80 ifTrue:
["A compressed format. Could copy what BitMap does, or use a
special sound compression format. Callers normally compress their own way."
^ self error: 'not implemented'].
s skip: -1.
len _ s nextInt32.
^ s nextWordsInto: (self basicNew: len)!
----- Method: ArrayedCollection class>>with: (in category 'instance creation') -----
with: anObject
"Answer a new instance of me, containing only anObject."
| newCollection |
newCollection _ self new: 1.
newCollection at: 1 put: anObject.
^newCollection!
----- Method: ArrayedCollection class>>with:with: (in category 'instance creation') -----
with: firstObject with: secondObject
"Answer a new instance of me, containing firstObject and secondObject."
| newCollection |
newCollection _ self new: 2.
newCollection at: 1 put: firstObject.
newCollection at: 2 put: secondObject.
^newCollection!
----- Method: ArrayedCollection class>>with:with:with: (in category 'instance creation') -----
with: firstObject with: secondObject with: thirdObject
"Answer a new instance of me, containing only the three arguments as
elements."
| newCollection |
newCollection _ self new: 3.
newCollection at: 1 put: firstObject.
newCollection at: 2 put: secondObject.
newCollection at: 3 put: thirdObject.
^newCollection!
----- Method: ArrayedCollection class>>with:with:with:with: (in category 'instance creation') -----
with: firstObject with: secondObject with: thirdObject with: fourthObject
"Answer a new instance of me, containing only the three arguments as
elements."
| newCollection |
newCollection _ self new: 4.
newCollection at: 1 put: firstObject.
newCollection at: 2 put: secondObject.
newCollection at: 3 put: thirdObject.
newCollection at: 4 put: fourthObject.
^newCollection!
----- Method: ArrayedCollection class>>with:with:with:with:with: (in category 'instance creation') -----
with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject
"Answer a new instance of me, containing only the five arguments as
elements."
| newCollection |
newCollection _ self new: 5.
newCollection at: 1 put: firstObject.
newCollection at: 2 put: secondObject.
newCollection at: 3 put: thirdObject.
newCollection at: 4 put: fourthObject.
newCollection at: 5 put: fifthObject.
^newCollection!
----- Method: ArrayedCollection class>>with:with:with:with:with:with: (in category 'instance creation') -----
with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject with: sixthObject
"Answer a new instance of me, containing only the 6 arguments as elements."
| newCollection |
newCollection _ self new: 6.
newCollection at: 1 put: firstObject.
newCollection at: 2 put: secondObject.
newCollection at: 3 put: thirdObject.
newCollection at: 4 put: fourthObject.
newCollection at: 5 put: fifthObject.
newCollection at: 6 put: sixthObject.
^ newCollection!
----- Method: ArrayedCollection class>>withAll: (in category 'instance creation') -----
withAll: aCollection
"Create a new collection containing all the elements from aCollection."
^ (self new: aCollection size) replaceFrom: 1 to: aCollection size with: aCollection!
----- Method: ArrayedCollection>>add: (in category 'adding') -----
add: newObject
self shouldNotImplement!
----- Method: ArrayedCollection>>asSortedArray (in category 'converting') -----
asSortedArray
self isSorted ifTrue: [^ self asArray].
^ super asSortedArray!
----- Method: ArrayedCollection>>byteSize (in category 'objects from disk') -----
byteSize
^self basicSize * self bytesPerBasicElement
!
----- Method: ArrayedCollection>>bytesPerBasicElement (in category 'objects from disk') -----
bytesPerBasicElement
"Answer the number of bytes that each of my basic elements requires.
In other words:
self basicSize * self bytesPerBasicElement
should equal the space required on disk by my variable sized representation."
^self class isBytes ifTrue: [ 1 ] ifFalse: [ 4 ]!
----- Method: ArrayedCollection>>bytesPerElement (in category 'objects from disk') -----
bytesPerElement
^self class isBytes ifTrue: [ 1 ] ifFalse: [ 4 ].
!
----- Method: ArrayedCollection>>defaultElement (in category 'private') -----
defaultElement
^nil!
----- Method: ArrayedCollection>>flattenOnStream: (in category 'filter streaming') -----
flattenOnStream: aStream
aStream writeArrayedCollection: self!
----- Method: ArrayedCollection>>isSorted (in category 'sorting') -----
isSorted
"Return true if the receiver is sorted by the given criterion.
Optimization for isSortedBy: [:a :b | a <= b]."
| lastElm elm |
self isEmpty ifTrue: [^ true].
lastElm _ self first.
2 to: self size do:
[:index |
elm _ self at: index.
lastElm <= elm ifFalse: [^ false].
lastElm _ elm].
^ true!
----- Method: ArrayedCollection>>isSortedBy: (in category 'sorting') -----
isSortedBy: aBlock
"Return true if the receiver is sorted by the given criterion."
| lastElm elm |
self isEmpty ifTrue: [^ true].
lastElm _ self first.
2 to: self size do:
[:index |
elm _ self at: index.
(aBlock value: lastElm value: elm) ifFalse: [^ false].
lastElm _ elm].
^ true!
----- Method: ArrayedCollection>>mergeFirst:middle:last:into:by: (in category 'sorting') -----
mergeFirst: first middle: middle last: last into: dst by: aBlock
"Private. Merge the sorted ranges [first..middle] and [middle+1..last]
of the receiver into the range [first..last] of dst."
| i1 i2 val1 val2 out |
i1 _ first.
i2 _ middle + 1.
val1 _ self at: i1.
val2 _ self at: i2.
out _ first - 1. "will be pre-incremented"
"select 'lower' half of the elements based on comparator"
[(i1 <= middle) and: [i2 <= last]] whileTrue:
[(aBlock value: val1 value: val2)
ifTrue: [dst at: (out _ out + 1) put: val1.
val1 _ self at: (i1 _ i1 + 1)]
ifFalse: [dst at: (out _ out + 1) put: val2.
i2 _ i2 + 1.
i2 <= last ifTrue: [val2 _ self at: i2]]].
"copy the remaining elements"
i1 <= middle
ifTrue: [dst replaceFrom: out + 1 to: last with: self startingAt: i1]
ifFalse: [dst replaceFrom: out + 1 to: last with: self startingAt: i2]!
----- Method: ArrayedCollection>>mergeSortFrom:to:by: (in category 'sorting') -----
mergeSortFrom: startIndex to: stopIndex by: aBlock
"Sort the given range of indices using the mergesort algorithm.
Mergesort is a worst-case O(N log N) sorting algorithm that usually
does only half as many comparisons as heapsort or quicksort."
"Details: recursively split the range to be sorted into two halves,
mergesort each half, then merge the two halves together. An extra
copy of the data is used as temporary storage and successive merge
phases copy data back and forth between the receiver and this copy.
The recursion is set up so that the final merge is performed into the
receiver, resulting in the receiver being completely sorted."
self size <= 1 ifTrue: [^ self]. "nothing to do"
startIndex = stopIndex ifTrue: [^ self].
self assert: [startIndex >= 1 and: [startIndex < stopIndex]]. "bad start index"
self assert: [stopIndex <= self size]. "bad stop index"
self
mergeSortFrom: startIndex
to: stopIndex
src: self clone
dst: self
by: aBlock!
----- Method: ArrayedCollection>>mergeSortFrom:to:src:dst:by: (in category 'sorting') -----
mergeSortFrom: first to: last src: src dst: dst by: aBlock
"Private. Split the range to be sorted in half, sort each half, and
merge the two half-ranges into dst."
| middle |
first = last ifTrue: [^ self].
middle _ (first + last) // 2.
self mergeSortFrom: first to: middle src: dst dst: src by: aBlock.
self mergeSortFrom: middle + 1 to: last src: dst dst: src by: aBlock.
src mergeFirst: first middle: middle last: last into: dst by: aBlock!
----- Method: ArrayedCollection>>restoreEndianness (in category 'objects from disk') -----
restoreEndianness
"This word object was just read in from a stream. It was stored in Big Endian (Mac) format. Reverse the byte order if the current machine is Little Endian.
We only intend this for non-pointer arrays. Do nothing if I contain pointers."
self class isPointers | self class isWords not ifTrue: [^self].
SmalltalkImage current isLittleEndian
ifTrue:
[Bitmap
swapBytesIn: self
from: 1
to: self basicSize]!
----- Method: ArrayedCollection>>size (in category 'accessing') -----
size
"Answer how many elements the receiver contains."
<primitive: 62>
^ self basicSize!
----- Method: ArrayedCollection>>sort (in category 'sorting') -----
sort
"Sort this array into ascending order using the '<=' operator."
self sort: [:a :b | a <= b]!
----- Method: ArrayedCollection>>sort: (in category 'sorting') -----
sort: aSortBlock
"Sort this array using aSortBlock. The block should take two arguments
and return true if the first element should preceed the second one."
self
mergeSortFrom: 1
to: self size
by: aSortBlock!
----- Method: ArrayedCollection>>storeElementsFrom:to:on: (in category 'private') -----
storeElementsFrom: firstIndex to: lastIndex on: aStream
| noneYet defaultElement arrayElement |
noneYet _ true.
defaultElement _ self defaultElement.
firstIndex to: lastIndex do:
[:index |
arrayElement _ self at: index.
arrayElement = defaultElement
ifFalse:
[noneYet
ifTrue: [noneYet _ false]
ifFalse: [aStream nextPut: $;].
aStream nextPutAll: ' at: '.
aStream store: index.
aStream nextPutAll: ' put: '.
aStream store: arrayElement]].
^noneYet!
----- Method: ArrayedCollection>>storeOn: (in category 'printing') -----
storeOn: aStream
aStream nextPutAll: '(('.
aStream nextPutAll: self class name.
aStream nextPutAll: ' new: '.
aStream store: self size.
aStream nextPut: $).
(self storeElementsFrom: 1 to: self size on: aStream)
ifFalse: [aStream nextPutAll: '; yourself'].
aStream nextPut: $)!
----- Method: ArrayedCollection>>swapBytesFrom:to: (in category 'objects from disk') -----
swapBytesFrom: start to: stop
"Perform a bigEndian/littleEndian byte reversal of my words.
We only intend this for non-pointer arrays. Do nothing if I contain pointers."
| hack blt |
self deprecated: 'Use BitMap class>>swapBytesIn:from:to:'.
self class isPointers | self class isWords not ifTrue: [^ self].
"The implementation is a hack, but fast for large ranges"
hack _ Form new hackBits: self.
blt _ (BitBlt toForm: hack) sourceForm: hack.
blt combinationRule: Form reverse. "XOR"
blt sourceY: start-1; destY: start-1; height: stop-start+1; width: 1.
blt sourceX: 0; destX: 3; copyBits. "Exchange bytes 0 and 3"
blt sourceX: 3; destX: 0; copyBits.
blt sourceX: 0; destX: 3; copyBits.
blt sourceX: 1; destX: 2; copyBits. "Exchange bytes 1 and 2"
blt sourceX: 2; destX: 1; copyBits.
blt sourceX: 1; destX: 2; copyBits.
!
----- Method: ArrayedCollection>>swapHalves (in category 'objects from disk') -----
swapHalves
"A normal switch in endianness (byte order in words) reverses the order of 4 bytes. That is not correct for SoundBuffers, which use 2-bytes units. If a normal switch has be done, this method corrects it further by swapping the two halves of the long word.
This method is only used for 16-bit quanities in SoundBuffer, ShortIntegerArray, etc."
| hack blt |
"The implementation is a hack, but fast for large ranges"
hack _ Form new hackBits: self.
blt _ (BitBlt toForm: hack) sourceForm: hack.
blt combinationRule: Form reverse. "XOR"
blt sourceY: 0; destY: 0; height: self size; width: 2.
blt sourceX: 0; destX: 2; copyBits. "Exchange bytes 0&1 with 2&3"
blt sourceX: 2; destX: 0; copyBits.
blt sourceX: 0; destX: 2; copyBits.!
----- Method: ArrayedCollection>>writeOn: (in category 'objects from disk') -----
writeOn: aStream
"Store the array of bits onto the argument, aStream. (leading byte ~= 16r80) identifies this as raw bits (uncompressed). Always store in Big Endian (Mac) byte order. Do the writing at BitBlt speeds. We only intend this for non-pointer arrays. Do nothing if I contain pointers."
self class isPointers | self class isWords not ifTrue: [^ super writeOn: aStream].
"super may cause an error, but will not be called."
aStream nextInt32Put: self basicSize.
aStream nextWordsPutAll: self.!
----- Method: ArrayedCollection>>writeOnGZIPByteStream: (in category 'objects from disk') -----
writeOnGZIPByteStream: aStream
"We only intend this for non-pointer arrays. Do nothing if I contain pointers."
self class isPointers | self class isWords not ifTrue: [^ super writeOnGZIPByteStream: aStream].
"super may cause an error, but will not be called."
aStream nextPutAllWordArray: self!
ArrayedCollection variableByteSubclass: #ByteArray
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Arrayed'!
!ByteArray commentStamp: '<historical>' prior: 0!
I represent an ArrayedCollection whose elements are integers between 0 and 255.
!
----- Method: ByteArray class>>ccg:emitLoadFor:from:on: (in category 'plugin generation') -----
ccg: cg emitLoadFor: aString from: anInteger on: aStream
cg emitLoad: aString asCharPtrFrom: anInteger on: aStream!
----- Method: ByteArray class>>ccg:prolog:expr:index: (in category 'plugin generation') -----
ccg: cg prolog: aBlock expr: aString index: anInteger
^cg
ccgLoad: aBlock
expr: aString
asCharPtrFrom: anInteger
andThen: (cg ccgValBlock: 'isBytes')!
----- Method: ByteArray class>>ccgDeclareCForVar: (in category 'plugin generation') -----
ccgDeclareCForVar: aSymbolOrString
^'char *', aSymbolOrString!
----- Method: ByteArray class>>hashBytes:startingWith: (in category 'byte based hash') -----
hashBytes: aByteArray startingWith: speciesHash
"Answer the hash of a byte-indexed collection,
using speciesHash as the initial value.
See SmallInteger>>hashMultiply.
The primitive should be renamed at a
suitable point in the future"
| byteArraySize hash low |
<primitive: 'primitiveStringHash' module: 'MiscPrimitivePlugin'>
self var: #aHash declareC: 'int speciesHash'.
self var: #aByteArray declareC: 'unsigned char *aByteArray'.
byteArraySize _ aByteArray size.
hash _ speciesHash bitAnd: 16rFFFFFFF.
1 to: byteArraySize do: [:pos |
hash _ hash + (aByteArray basicAt: pos).
"Begin hashMultiply"
low _ hash bitAnd: 16383.
hash _ (16r260D * low + ((16r260D * (hash bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384)) bitAnd: 16r0FFFFFFF.
].
^ hash!
----- Method: ByteArray>>asByteArray (in category 'converting') -----
asByteArray
^ self!
----- Method: ByteArray>>asByteArrayPointer (in category 'private') -----
asByteArrayPointer
"Return a ByteArray describing a pointer to the contents of the receiver."
^self shouldNotImplement!
----- Method: ByteArray>>asSocketAddress (in category 'converting') -----
asSocketAddress
^SocketAddress fromOldByteAddress: self!
----- Method: ByteArray>>asString (in category 'converting') -----
asString
"Convert to a String with Characters for each byte.
Fast code uses primitive that avoids character conversion"
^ (String new: self size) replaceFrom: 1 to: self size with: self!
----- Method: ByteArray>>asWideString (in category 'accessing') -----
asWideString
^ WideString fromByteArray: self.
!
----- Method: ByteArray>>atAllPut: (in category 'accessing') -----
atAllPut: value
"Fill the receiver with the given value"
<primitive: 145>
super atAllPut: value!
----- Method: ByteArray>>byteAt: (in category 'accessing') -----
byteAt: index
<primitive: 60>
^self at: index!
----- Method: ByteArray>>byteAt:put: (in category 'accessing') -----
byteAt: index put: value
<primitive: 61>
^self at: index put: value!
----- Method: ByteArray>>byteSize (in category 'accessing') -----
byteSize
^self size!
----- Method: ByteArray>>bytesPerElement (in category 'accessing') -----
bytesPerElement
"Number of bytes in each item. This multiplied by (self size)*8 gives the number of bits stored."
^ 1!
----- Method: ByteArray>>copy (in category 'copying') -----
copy
^ self clone.
!
----- Method: ByteArray>>defaultElement (in category 'private') -----
defaultElement
^0!
----- Method: ByteArray>>hash (in category 'comparing') -----
hash
"#hash is implemented, because #= is implemented"
^self class
hashBytes: self
startingWith: self species hash!
----- Method: ByteArray>>isLiteral (in category 'testing') -----
isLiteral
"so that #(1 #[1 2 3] 5) prints itself"
^ true!
----- Method: ByteArray>>lastIndexOfPKSignature: (in category 'zip archive') -----
lastIndexOfPKSignature: aSignature
"Answer the last index in me where aSignature (4 bytes long) occurs, or 0 if not found"
| a b c d |
a _ aSignature first.
b _ aSignature second.
c _ aSignature third.
d _ aSignature fourth.
(self size - 3) to: 1 by: -1 do: [ :i |
(((self at: i) = a)
and: [ ((self at: i + 1) = b)
and: [ ((self at: i + 2) = c)
and: [ ((self at: i + 3) = d) ]]])
ifTrue: [ ^i ]
].
^0!
----- Method: ByteArray>>longAt:bigEndian: (in category 'platform independent access') -----
longAt: index bigEndian: aBool
"Return a 32bit integer quantity starting from the given byte index"
| b0 b1 b2 w h |
aBool ifTrue:[
b0 _ self at: index.
b1 _ self at: index+1.
b2 _ self at: index+2.
w _ self at: index+3.
] ifFalse:[
w _ self at: index.
b2 _ self at: index+1.
b1 _ self at: index+2.
b0 _ self at: index+3.
].
"Minimize LargeInteger arithmetic"
h _ ((b0 bitAnd: 16r7F) - (b0 bitAnd: 16r80) bitShift: 8) + b1.
b2 = 0 ifFalse:[w _ (b2 bitShift: 8) + w].
h = 0 ifFalse:[w _ (h bitShift: 16) + w].
^w!
----- Method: ByteArray>>longAt:put:bigEndian: (in category 'platform independent access') -----
longAt: index put: value bigEndian: aBool
"Return a 32bit integer quantity starting from the given byte index"
| b0 b1 b2 b3 |
b0 _ value bitShift: -24.
b0 _ (b0 bitAnd: 16r7F) - (b0 bitAnd: 16r80).
b0 < 0 ifTrue:[b0 := 256 + b0].
b1 _ (value bitShift: -16) bitAnd: 255.
b2 _ (value bitShift: -8) bitAnd: 255.
b3 _ value bitAnd: 255.
aBool ifTrue:[
self at: index put: b0.
self at: index+1 put: b1.
self at: index+2 put: b2.
self at: index+3 put: b3.
] ifFalse:[
self at: index put: b3.
self at: index+1 put: b2.
self at: index+2 put: b1.
self at: index+3 put: b0.
].
^value!
----- Method: ByteArray>>printOn: (in category 'printing') -----
printOn: aStream
aStream nextPutAll: '#['.
self
do: [ :each | each printOn: aStream ]
separatedBy: [ aStream nextPut: $ ].
aStream nextPut: $]!
----- Method: ByteArray>>replaceFrom:to:with:startingAt: (in category '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!
----- Method: ByteArray>>shallowCopy (in category 'copying') -----
shallowCopy
^ self clone.
!
----- Method: ByteArray>>shortAt:bigEndian: (in category 'platform independent access') -----
shortAt: index bigEndian: aBool
"Return a 16 bit integer quantity starting from the given byte index"
| uShort |
uShort _ self unsignedShortAt: index bigEndian: aBool.
^(uShort bitAnd: 16r7FFF) - (uShort bitAnd: 16r8000)!
----- Method: ByteArray>>shortAt:put:bigEndian: (in category 'platform independent access') -----
shortAt: index put: value bigEndian: aBool
"Store a 16 bit integer quantity starting from the given byte index"
self unsignedShortAt: index put: (value bitAnd: 16r7FFF) - (value bitAnd: -16r8000) bigEndian: aBool.
^value!
----- Method: ByteArray>>storeOn: (in category 'printing') -----
storeOn: aStream
aStream nextPutAll: '#['.
self
do: [ :each | each storeOn: aStream ]
separatedBy: [ aStream nextPut: $ ].
aStream nextPut: $]!
----- Method: ByteArray>>unsignedLongAt:bigEndian: (in category 'platform independent access') -----
unsignedLongAt: index bigEndian: aBool
"Return a 32bit unsigned integer quantity starting from the given byte index"
| b0 b1 b2 w |
aBool ifTrue:[
b0 _ self at: index.
b1 _ self at: index+1.
b2 _ self at: index+2.
w _ self at: index+3.
] ifFalse:[
w _ self at: index.
b2 _ self at: index+1.
b1 _ self at: index+2.
b0 _ self at: index+3.
].
"Minimize LargeInteger arithmetic"
b2 = 0 ifFalse:[w _ (b2 bitShift: 8) + w].
b1 = 0 ifFalse:[w _ (b1 bitShift: 16) + w].
b0 = 0 ifFalse:[w _ (b0 bitShift: 24) + w].
^w!
----- Method: ByteArray>>unsignedLongAt:put:bigEndian: (in category 'platform independent access') -----
unsignedLongAt: index put: value bigEndian: aBool
"Store a 32bit unsigned integer quantity starting from the given byte index"
| b0 b1 b2 b3 |
b0 _ value bitShift: -24.
b1 _ (value bitShift: -16) bitAnd: 255.
b2 _ (value bitShift: -8) bitAnd: 255.
b3 _ value bitAnd: 255.
aBool ifTrue:[
self at: index put: b0.
self at: index+1 put: b1.
self at: index+2 put: b2.
self at: index+3 put: b3.
] ifFalse:[
self at: index put: b3.
self at: index+1 put: b2.
self at: index+2 put: b1.
self at: index+3 put: b0.
].
^value!
----- Method: ByteArray>>unsignedShortAt:bigEndian: (in category 'platform independent access') -----
unsignedShortAt: index bigEndian: aBool
"Return a 16 bit unsigned integer quantity starting from the given byte index"
^aBool
ifTrue:[((self at: index) bitShift: 8) + (self at: index+1)]
ifFalse:[((self at: index+1) bitShift: 8) + (self at: index)].!
----- Method: ByteArray>>unsignedShortAt:put:bigEndian: (in category 'platform independent access') -----
unsignedShortAt: index put: value bigEndian: aBool
"Store a 16 bit unsigned integer quantity starting from the given byte index"
aBool ifTrue:[
self at: index put: (value bitShift: -8).
self at: index+1 put: (value bitAnd: 255).
] ifFalse:[
self at: index+1 put: (value bitShift: -8).
self at: index put: (value bitAnd: 255).
].
^value!
ArrayedCollection variableWordSubclass: #ColorArray
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Arrayed'!
----- Method: ColorArray>>asColorArray (in category 'converting') -----
asColorArray
^self!
----- Method: ColorArray>>at: (in category 'accessing') -----
at: index
^(super at: index) asColorOfDepth: 32!
----- Method: ColorArray>>at:put: (in category 'accessing') -----
at: index put: aColor
^super at: index put: (aColor pixelWordForDepth: 32).!
----- Method: ColorArray>>bytesPerElement (in category 'converting') -----
bytesPerElement
^4!
ArrayedCollection variableWordSubclass: #FloatArray
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Arrayed'!
!FloatArray commentStamp: '<historical>' prior: 0!
FloatArrays store 32bit IEEE floating point numbers.!
----- Method: FloatArray class>>ccg:emitLoadFor:from:on: (in category 'plugin generation') -----
ccg: cg emitLoadFor: aString from: anInteger on: aStream
cg emitLoad: aString asFloatPtrFrom: anInteger on: aStream!
----- Method: FloatArray class>>ccg:prolog:expr:index: (in category 'plugin generation') -----
ccg: cg prolog: aBlock expr: aString index: anInteger
^cg ccgLoad: aBlock expr: aString asWBFloatPtrFrom: anInteger!
----- Method: FloatArray class>>ccgDeclareCForVar: (in category 'plugin generation') -----
ccgDeclareCForVar: aSymbolOrString
^'float *', aSymbolOrString!
----- Method: FloatArray>>* (in category 'arithmetic') -----
* anObject
^self clone *= anObject!
----- Method: FloatArray>>*= (in category 'arithmetic') -----
*= anObject
^anObject isNumber
ifTrue:[self primMulScalar: anObject asFloat]
ifFalse:[self primMulArray: anObject]!
----- Method: FloatArray>>+ (in category 'arithmetic') -----
+ anObject
^self clone += anObject!
----- Method: FloatArray>>+= (in category 'arithmetic') -----
+= anObject
^anObject isNumber
ifTrue:[self primAddScalar: anObject asFloat]
ifFalse:[self primAddArray: anObject]!
----- Method: FloatArray>>- (in category 'arithmetic') -----
- anObject
^self clone -= anObject!
----- Method: FloatArray>>-= (in category 'arithmetic') -----
-= anObject
^anObject isNumber
ifTrue:[self primSubScalar: anObject asFloat]
ifFalse:[self primSubArray: anObject]!
----- Method: FloatArray>>/ (in category 'arithmetic') -----
/ anObject
^self clone /= anObject!
----- Method: FloatArray>>/= (in category 'arithmetic') -----
/= anObject
^anObject isNumber
ifTrue:[self primDivScalar: anObject asFloat]
ifFalse:[self primDivArray: anObject]!
----- Method: FloatArray>>\\= (in category 'arithmetic') -----
\\= other
other isNumber ifTrue: [
1 to: self size do: [:i |
self at: i put: (self at: i) \\ other
].
^ self.
].
1 to: (self size min: other size) do: [:i |
self at: i put: (self at: i) \\ (other at: i).
].
!
----- Method: FloatArray>>adaptToNumber:andSend: (in category 'arithmetic') -----
adaptToNumber: rcvr andSend: selector
"If I am involved in arithmetic with a Number. If possible,
convert it to a float and perform the (more efficient) primitive operation."
selector == #+ ifTrue:[^self + rcvr].
selector == #* ifTrue:[^self * rcvr].
selector == #- ifTrue:[^self negated += rcvr].
selector == #/ ifTrue:[^self * (1.0 / rcvr)].
^super adaptToNumber: rcvr andSend: selector!
----- Method: FloatArray>>asFloatArray (in category 'converting') -----
asFloatArray
^self!
----- Method: FloatArray>>at: (in category 'accessing') -----
at: index
<primitive: 'primitiveAt' module: 'FloatArrayPlugin'>
^Float fromIEEE32Bit: (self basicAt: index)!
----- Method: FloatArray>>at:put: (in category 'accessing') -----
at: index put: value
<primitive: 'primitiveAtPut' module: 'FloatArrayPlugin'>
value isFloat
ifTrue:[self basicAt: index put: value asIEEE32BitWord]
ifFalse:[self at: index put: value asFloat].
^value!
----- Method: FloatArray>>defaultElement (in category 'accessing') -----
defaultElement
"Return the default element of the receiver"
^0.0!
----- Method: FloatArray>>dot: (in category 'arithmetic') -----
dot: aFloatVector
"Primitive. Return the dot product of the receiver and the argument.
Fail if the argument is not of the same size as the receiver."
| result |
"<primitive:'primitiveFloatArrayDotProduct'>"
self size = aFloatVector size ifFalse:[^self error:'Must be equal size'].
result _ 0.0.
1 to: self size do:[:i|
result _ result + ((self at: i) * (aFloatVector at: i)).
].
^result!
----- Method: FloatArray>>hash (in category 'comparing') -----
hash
| result |
<primitive:'primitiveHashArray' module: 'FloatArrayPlugin'>
result _ 0.
1 to: self size do:[:i| result _ result + (self basicAt: i) ].
^result bitAnd: 16r1FFFFFFF!
----- Method: FloatArray>>length (in category 'accessing') -----
length
"Return the length of the receiver"
^self squaredLength sqrt!
----- Method: FloatArray>>negated (in category 'arithmetic') -----
negated
^self clone *= -1!
----- Method: FloatArray>>primAddArray: (in category 'primitives-plugin') -----
primAddArray: floatArray
<primitive: 'primitiveAddFloatArray' module: 'FloatArrayPlugin'>
1 to: self size do:[:i| self at: i put: (self at: i) + (floatArray at: i)].!
----- Method: FloatArray>>primAddScalar: (in category 'primitives-plugin') -----
primAddScalar: scalarValue
<primitive: 'primitiveAddScalar' module: 'FloatArrayPlugin'>
1 to: self size do:[:i| self at: i put: (self at: i) + scalarValue].!
----- Method: FloatArray>>primDivArray: (in category 'primitives-plugin') -----
primDivArray: floatArray
<primitive: 'primitiveDivFloatArray' module: 'FloatArrayPlugin'>
1 to: self size do:[:i| self at: i put: (self at: i) / (floatArray at: i)].!
----- Method: FloatArray>>primDivScalar: (in category 'primitives-plugin') -----
primDivScalar: scalarValue
<primitive: 'primitiveDivScalar' module: 'FloatArrayPlugin'>
1 to: self size do:[:i| self at: i put: (self at: i) / scalarValue].!
----- Method: FloatArray>>primMulArray: (in category 'primitives-plugin') -----
primMulArray: floatArray
<primitive: 'primitiveMulFloatArray' module: 'FloatArrayPlugin'>
1 to: self size do:[:i| self at: i put: (self at: i) * (floatArray at: i)].!
----- Method: FloatArray>>primMulScalar: (in category 'primitives-plugin') -----
primMulScalar: scalarValue
<primitive: 'primitiveMulScalar' module: 'FloatArrayPlugin'>
1 to: self size do:[:i| self at: i put: (self at: i) * scalarValue].!
----- Method: FloatArray>>primSubArray: (in category 'primitives-plugin') -----
primSubArray: floatArray
<primitive: 'primitiveSubFloatArray' module: 'FloatArrayPlugin'>
1 to: self size do:[:i| self at: i put: (self at: i) - (floatArray at: i)].!
----- Method: FloatArray>>primSubScalar: (in category 'primitives-plugin') -----
primSubScalar: scalarValue
<primitive: 'primitiveSubScalar' module: 'FloatArrayPlugin'>
1 to: self size do:[:i| self at: i put: (self at: i) - scalarValue].!
----- Method: FloatArray>>replaceFrom:to:with:startingAt: (in category '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!
----- Method: FloatArray>>squaredLength (in category 'accessing') -----
squaredLength
"Return the squared length of the receiver"
^self dot: self!
----- Method: FloatArray>>sum (in category 'primitives-plugin') -----
sum
<primitive: 'primitiveSum' module: 'FloatArrayPlugin'>
^ super sum!
ArrayedCollection variableWordSubclass: #IntegerArray
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Arrayed'!
!IntegerArray commentStamp: '<historical>' prior: 0!
IntegerArrays store 32bit signed Integer values.
Negative values are stored as 2's complement.!
----- Method: IntegerArray class>>ccg:emitLoadFor:from:on: (in category 'plugin generation') -----
ccg: cg emitLoadFor: aString from: anInteger on: aStream
cg emitLoad: aString asIntPtrFrom: anInteger on: aStream!
----- Method: IntegerArray class>>ccg:prolog:expr:index: (in category 'plugin generation') -----
ccg: cg prolog: aBlock expr: aString index: anInteger
^cg
ccgLoad: aBlock
expr: aString
asIntPtrFrom: anInteger
andThen: (cg ccgValBlock: 'isWords')!
----- Method: IntegerArray class>>ccgDeclareCForVar: (in category 'plugin generation') -----
ccgDeclareCForVar: aSymbolOrString
^'int *', aSymbolOrString!
----- Method: IntegerArray>>asIntegerArray (in category 'converting') -----
asIntegerArray
^self!
----- Method: IntegerArray>>at: (in category 'accessing') -----
at: index
| word |
<primitive: 165>
word _ self basicAt: index.
word < 16r3FFFFFFF ifTrue:[^word]. "Avoid LargeInteger computations"
^word >= 16r80000000 "Negative?!!"
ifTrue:["word - 16r100000000"
(word bitInvert32 + 1) negated]
ifFalse:[word]!
----- Method: IntegerArray>>at:put: (in category 'accessing') -----
at: index put: anInteger
| word |
<primitive: 166>
anInteger < 0
ifTrue:["word _ 16r100000000 + anInteger"
word _ (anInteger + 1) negated bitInvert32]
ifFalse:[word _ anInteger].
self basicAt: index put: word.
^anInteger!
----- Method: IntegerArray>>atAllPut: (in category 'accessing') -----
atAllPut: anInteger
| word |
anInteger < 0
ifTrue:["word _ 16r100000000 + anInteger"
word _ (anInteger + 1) negated bitInvert32]
ifFalse:[word _ anInteger].
self primFill: word.!
----- Method: IntegerArray>>defaultElement (in category 'accessing') -----
defaultElement
"Return the default element of the receiver"
^0!
----- Method: IntegerArray>>primFill: (in category 'private') -----
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."
<primitive: 145>
self errorImproperStore.!
ArrayedCollection subclass: #RunArray
instanceVariableNames: 'runs values lastIndex lastRun lastOffset pangoAttrCache'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Arrayed'!
!RunArray commentStamp: '<historical>' prior: 0!
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" length that denotes the number of consecutive occurrences of the value.
My two important variables are
runs An array of how many elements are in each run
values An array of what the value is over those elements
The variables lastIndex, lastRun and lastOffset cache the last access
so that streaming through RunArrays is not an N-squared process.
Many complexities of access can be bypassed by using the method
RunArray withStartStopAndValueDo:!
----- Method: RunArray class>>new (in category 'instance creation') -----
new
^self runs: Array new values: Array new!
----- Method: RunArray class>>new:withAll: (in category 'instance creation') -----
new: size withAll: value
"Answer a new instance of me, whose every element is equal to the
argument, value."
size = 0 ifTrue: [^self new].
^self runs: (Array with: size) values: (Array with: value)!
----- Method: RunArray class>>newFrom: (in category 'instance creation') -----
newFrom: aCollection
"Answer an instance of me containing the same elements as aCollection."
| newCollection |
newCollection _ self new.
aCollection do: [:x | newCollection addLast: x].
^newCollection
" RunArray newFrom: {1. 2. 2. 3}
{1. $a. $a. 3} as: RunArray
({1. $a. $a. 3} as: RunArray) values
"!
----- Method: RunArray class>>readFrom: (in category 'instance creation') -----
readFrom: aStream
"Answer an instance of me as described on the stream, aStream."
| size runs values |
size _ aStream nextWord.
runs _ Array new: size.
values _ Array new: size.
1 to: size do:
[:x |
runs at: x put: aStream nextWord.
values at: x put: aStream nextWord].
^ self runs: runs values: values!
----- Method: RunArray class>>runs:values: (in category 'instance creation') -----
runs: newRuns values: newValues
"Answer an instance of me with runs and values specified by the
arguments."
| instance |
instance _ self basicNew.
instance setRuns: newRuns setValues: newValues.
^instance!
----- Method: RunArray class>>scanFrom: (in category 'instance creation') -----
scanFrom: strm
"Read the style section of a fileOut or sources file. nextChunk has already been done. We need to return a RunArray of TextAttributes of various kinds. These are written by the implementors of writeScanOn:"
| rr vv aa this |
(strm peekFor: $( ) ifFalse: [^ nil].
rr _ OrderedCollection new.
[strm skipSeparators.
strm peekFor: $)] whileFalse:
[rr add: (Number readFrom: strm)].
vv _ OrderedCollection new. "Value array"
aa _ OrderedCollection new. "Attributes list"
[(this _ strm next) == nil] whileFalse: [
this == $, ifTrue: [vv add: aa asArray. aa _ OrderedCollection new].
this == $a ifTrue: [aa add:
(TextAlignment new alignment: (Integer readFrom: strm))].
this == $f ifTrue: [aa add:
(TextFontChange new fontNumber: (Integer readFrom: strm))].
this == $F ifTrue: [aa add: (TextFontReference toFont:
(StrikeFont familyName: (strm upTo: $#) size: (Integer readFrom: strm)))].
this == $b ifTrue: [aa add: (TextEmphasis bold)].
this == $i ifTrue: [aa add: (TextEmphasis italic)].
this == $u ifTrue: [aa add: (TextEmphasis underlined)].
this == $= ifTrue: [aa add: (TextEmphasis struckOut)].
this == $n ifTrue: [aa add: (TextEmphasis normal)].
this == $- ifTrue: [aa add: (TextKern kern: -1)].
this == $+ ifTrue: [aa add: (TextKern kern: 1)].
this == $c ifTrue: [aa add: (TextColor scanFrom: strm)]. "color"
this == $L ifTrue: [aa add: (TextLink scanFrom: strm)]. "L not look like 1"
this == $R ifTrue: [aa add: (TextURL scanFrom: strm)].
"R capitalized so it can follow a number"
this == $q ifTrue: [aa add: (TextSqkPageLink scanFrom: strm)].
this == $p ifTrue: [aa add: (TextSqkProjectLink scanFrom: strm)].
this == $P ifTrue: [aa add: (TextPrintIt scanFrom: strm)].
this == $d ifTrue: [aa add: (TextDoIt scanFrom: strm)].
"space, cr do nothing"
].
aa size > 0 ifTrue: [vv add: aa asArray].
^ self runs: rr asArray values: vv asArray
"
RunArray scanFrom: (ReadStream on: '(14 50 312)f1,f1b,f1LInteger +;i')
"!
----- Method: RunArray>>, (in category 'copying') -----
, aRunArray
"Answer a new RunArray that is a concatenation of the receiver and
aRunArray."
| new newRuns |
(aRunArray isMemberOf: RunArray)
ifFalse:
[new _ self copy.
"attempt to be sociable"
aRunArray do: [:each | new addLast: each].
^new].
runs size = 0 ifTrue: [^aRunArray copy].
aRunArray runs size = 0 ifTrue: [^self copy].
(values at: values size) ~= (aRunArray values at: 1)
ifTrue: [^RunArray
runs: runs , aRunArray runs
values: values , aRunArray values].
newRuns _ runs
copyReplaceFrom: runs size
to: runs size
with: aRunArray runs.
newRuns at: runs size put: (runs at: runs size) + (aRunArray runs at: 1).
^RunArray
runs: newRuns
values:
(values
copyReplaceFrom: values size
to: values size
with: aRunArray values)!
----- Method: RunArray>>= (in category 'accessing') -----
= otherArray
"Test if all my elements are equal to those of otherArray"
(otherArray isMemberOf: RunArray) ifFalse: [^ self hasEqualElements: otherArray].
"Faster test between two RunArrays"
^ (runs hasEqualElements: otherArray runs)
and: [values hasEqualElements: otherArray values]!
----- Method: RunArray>>addFirst: (in category 'adding') -----
addFirst: value
"Add value as the first element of the receiver."
self clearCache. "flush access cache"
(runs size=0 or: [values first ~= value])
ifTrue:
[runs := {1}, runs.
values := {value}, values]
ifFalse:
[runs at: 1 put: runs first+1]!
----- Method: RunArray>>addLast: (in category 'adding') -----
addLast: value
"Add value as the last element of the receiver."
self clearCache. "flush access cache"
(runs size=0 or: [values last ~= value])
ifTrue:
[runs := runs copyWith: 1.
values := values copyWith: value]
ifFalse:
[runs at: runs size put: runs last+1]!
----- Method: RunArray>>addLast:times: (in category 'adding') -----
addLast: value times: times
"Add value as the last element of the receiver, the given number of times"
times = 0 ifTrue: [ ^self ].
self clearCache. "flush access cache"
(runs size=0 or: [values last ~= value])
ifTrue:
[runs := runs copyWith: times.
values := values copyWith: value]
ifFalse:
[runs at: runs size put: runs last+times]!
----- Method: RunArray>>at: (in category 'accessing') -----
at: index
self at: index setRunOffsetAndValue: [:run :offset :value | ^value]!
----- Method: RunArray>>at:setRunOffsetAndValue: (in category 'private') -----
at: index setRunOffsetAndValue: aBlock
"Supply all run information to aBlock."
"Tolerates index=0 and index=size+1 for copyReplace: "
| run limit offset |
limit _ runs size.
(lastIndex == nil or: [index < lastIndex])
ifTrue: "cache not loaded, or beyond index - start over"
[run _ 1.
offset _ index-1]
ifFalse: "cache loaded and before index - start at cache"
[run _ lastRun.
offset _ lastOffset + (index-lastIndex)].
[run <= limit and: [offset >= (runs at: run)]]
whileTrue:
[offset _ offset - (runs at: run).
run _ run + 1].
lastIndex _ index. "Load cache for next access"
lastRun _ run.
lastOffset _ offset.
run > limit
ifTrue:
["adjustment for size+1"
run _ run - 1.
offset _ offset + (runs at: run)].
^aBlock
value: run "an index into runs and values"
value: offset "zero-based offset from beginning of this run"
value: (values at: run) "value for this run"!
----- Method: RunArray>>coalesce (in category 'adding') -----
coalesce
"Try to combine adjacent runs"
| ind |
ind _ 2.
[ind > values size] whileFalse: [
(values at: ind-1) = (values at: ind)
ifFalse: [ind _ ind + 1]
ifTrue: ["two are the same, combine them"
values _ values copyReplaceFrom: ind to: ind with: #().
runs at: ind-1 put: (runs at: ind-1) + (runs at: ind).
runs _ runs copyReplaceFrom: ind to: ind with: #().
"self error: 'needed to combine runs' "]].
!
----- Method: RunArray>>copyFrom:to: (in category 'copying') -----
copyFrom: start to: stop
| newRuns run1 run2 offset1 offset2 |
stop < start ifTrue: [^RunArray new].
self at: start setRunOffsetAndValue: [:r :o :value1 | run1 _ r. offset1
_ o. value1].
self at: stop setRunOffsetAndValue: [:r :o :value2 | run2 _ r. offset2
_ o. value2].
run1 = run2
ifTrue:
[newRuns _ Array with: offset2 - offset1 + 1]
ifFalse:
[newRuns _ runs copyFrom: run1 to: run2.
newRuns at: 1 put: (newRuns at: 1) - offset1.
newRuns at: newRuns size put: offset2 + 1].
^RunArray runs: newRuns values: (values copyFrom: run1 to: run2)!
----- Method: RunArray>>copyReplaceFrom:to:with: (in category 'copying') -----
copyReplaceFrom: start to: stop with: replacement
^(self copyFrom: 1 to: start - 1)
, replacement
, (self copyFrom: stop + 1 to: self size)!
----- Method: RunArray>>first (in category 'accessing') -----
first
^values at: 1!
----- Method: RunArray>>last (in category 'accessing') -----
last
^values at: values size!
----- Method: RunArray>>mapValues: (in category 'private') -----
mapValues: mapBlock
"NOTE: only meaningful to an entire set of runs"
values _ values collect: [:val | mapBlock value: val]!
----- Method: RunArray>>printOn: (in category 'printing') -----
printOn: aStream
self printNameOn: aStream.
aStream
nextPutAll: ' runs: ';
print: runs;
nextPutAll: ' values: ';
print: values!
----- Method: RunArray>>rangeOf:startingAt: (in category 'adding') -----
rangeOf: attr startingAt: startPos
"Answer an interval that gives the range of attr at index position startPos. An empty interval with start value startPos is returned when the attribute attr is not present at position startPos. self size > 0 is assumed, it is the responsibility of the caller to test for emptiness of self.
Note that an attribute may span several adjancent runs. "
self at: startPos
setRunOffsetAndValue:
[:run :offset :value |
^(value includes: attr)
ifFalse: [startPos to: startPos - 1]
ifTrue:
[ | firstRelevantPosition lastRelevantPosition idxOfCandidateRun |
lastRelevantPosition := startPos - offset + (runs at: run) - 1.
firstRelevantPosition := startPos - offset.
idxOfCandidateRun := run + 1.
[idxOfCandidateRun <= runs size
and: [(values at: idxOfCandidateRun) includes: attr]]
whileTrue:
[lastRelevantPosition := lastRelevantPosition + (runs at: idxOfCandidateRun).
idxOfCandidateRun := idxOfCandidateRun + 1].
idxOfCandidateRun := run - 1.
[idxOfCandidateRun >= 1
and: [(values at: idxOfCandidateRun) includes: attr]]
whileTrue:
[firstRelevantPosition := firstRelevantPosition - (runs at: idxOfCandidateRun).
idxOfCandidateRun := idxOfCandidateRun - 1].
firstRelevantPosition to: lastRelevantPosition]
]!
----- Method: RunArray>>repeatLast:ifEmpty: (in category 'adding') -----
repeatLast: times ifEmpty: defaultBlock
"add the last value back again, the given number of times. If we are empty, add (defaultBlock value)"
times = 0 ifTrue: [^self ].
self clearCache. "flush access cache"
(runs size=0)
ifTrue:
[runs := runs copyWith: times.
values := values copyWith: defaultBlock value]
ifFalse:
[runs at: runs size put: runs last+times] !
----- Method: RunArray>>repeatLastIfEmpty: (in category 'adding') -----
repeatLastIfEmpty: defaultBlock
"add the last value back again. If we are empty, add (defaultBlock value)"
self clearCache. "flush access cache"
(runs size=0)
ifTrue:[
runs := runs copyWith: 1.
values := values copyWith: defaultBlock value]
ifFalse:
[runs at: runs size put: runs last+1]!
----- Method: RunArray>>reversed (in category 'converting') -----
reversed
^self class runs: runs reversed values: values reversed!
----- Method: RunArray>>runLengthAt: (in category 'accessing') -----
runLengthAt: index
"Answer the length remaining in run beginning at index."
self at: index
setRunOffsetAndValue: [:run :offset :value | ^(runs at: run) - offset]!
----- Method: RunArray>>runs (in category 'private') -----
runs
^runs!
----- Method: RunArray>>runsAndValuesDo: (in category 'enumerating') -----
runsAndValuesDo: aBlock
"Evaluate aBlock with run lengths and values from the receiver"
^runs with: values do: aBlock.!
----- Method: RunArray>>runsFrom:to:do: (in category 'enumerating') -----
runsFrom: start to: stop do: aBlock
"Evaluate aBlock with all existing runs in the range from start to stop"
| run value index |
start > stop ifTrue:[^self].
self at: start setRunOffsetAndValue:[:firstRun :offset :firstValue|
run _ firstRun.
value _ firstValue.
index _ start + (runs at: run) - offset.
[aBlock value: value.
index <= stop] whileTrue:[
run _ run + 1.
value _ values at: run.
index _ index + (runs at: run)]].
!
----- Method: RunArray>>setRuns:setValues: (in category 'private') -----
setRuns: newRuns setValues: newValues
self clearCache. "flush access cache"
runs := newRuns asArray.
values := newValues asArray.!
----- Method: RunArray>>size (in category 'accessing') -----
size
| size |
size _ 0.
1 to: runs size do: [:i | size _ size + (runs at: i)].
^size!
----- Method: RunArray>>storeOn: (in category 'printing') -----
storeOn: aStream
aStream nextPut: $(.
aStream nextPutAll: self class name.
aStream nextPutAll: ' runs: '.
runs storeOn: aStream.
aStream nextPutAll: ' values: '.
values storeOn: aStream.
aStream nextPut: $)!
----- Method: RunArray>>values (in category 'private') -----
values
"Answer the values in the receiver."
^values!
----- Method: RunArray>>withStartStopAndValueDo: (in category 'accessing') -----
withStartStopAndValueDo: aBlock
| start stop |
start _ 1.
runs with: values do:
[:len : val | stop _ start + len - 1.
aBlock value: start value: stop value: val.
start _ stop + 1]
!
----- Method: RunArray>>writeOn: (in category 'printing') -----
writeOn: aStream
aStream nextWordPut: runs size.
1 to: runs size do:
[:x |
aStream nextWordPut: (runs at: x).
aStream nextWordPut: (values at: x)]!
----- Method: RunArray>>writeScanOn: (in category 'printing') -----
writeScanOn: strm
"Write out the format used for text runs in source files. (14 50 312)f1,f1b,f1LInteger +;i"
strm nextPut: $(.
runs do: [:rr | rr printOn: strm. strm space].
strm skip: -1; nextPut: $).
values do: [:vv |
vv do: [:att | att writeScanOn: strm].
strm nextPut: $,].
strm skip: -1. "trailing comma"!
ArrayedCollection variableSubclass: #SparseLargeTable
instanceVariableNames: 'base size chunkSize defaultValue'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Arrayed'!
!SparseLargeTable commentStamp: '<historical>' prior: 0!
Derivated from Stephan Pair's LargeArray, but to hold a sparse table, in which most of the entries are the same default value, it uses some tricks.!
----- Method: SparseLargeTable class>>defaultChunkSize (in category 'accessing') -----
defaultChunkSize
^100!
----- Method: SparseLargeTable class>>defaultChunkSizeForFiles (in category 'accessing') -----
defaultChunkSizeForFiles
^8000!
----- Method: SparseLargeTable class>>new: (in category 'instance creation') -----
new: size
^self new: size chunkSize: self defaultChunkSize
!
----- Method: SparseLargeTable class>>new:chunkSize: (in category 'instance creation') -----
new: size chunkSize: chunkSize
^self new: size chunkSize: chunkSize arrayClass: Array
!
----- Method: SparseLargeTable class>>new:chunkSize:arrayClass: (in category 'instance creation') -----
new: size chunkSize: chunkSize arrayClass: aClass
^self new: size chunkSize: chunkSize arrayClass: Array base: 1.
!
----- Method: SparseLargeTable class>>new:chunkSize:arrayClass:base: (in category 'instance creation') -----
new: size chunkSize: chunkSize arrayClass: aClass base: b
^self new: size chunkSize: chunkSize arrayClass: Array base: 1 defaultValue: nil.
!
----- Method: SparseLargeTable class>>new:chunkSize:arrayClass:base:defaultValue: (in category 'instance creation') -----
new: size chunkSize: chunkSize arrayClass: aClass base: b defaultValue: d
| basicSize |
(basicSize := ((size - 1) // chunkSize) + 1) = 0
ifTrue: [basicSize := 1].
^(self basicNew: basicSize)
initChunkSize: chunkSize size: size arrayClass: aClass base: b defaultValue: d;
yourself
!
----- Method: SparseLargeTable>>allDefaultValueSubtableAt: (in category 'private') -----
allDefaultValueSubtableAt: index
| t |
t _ self basicAt: index.
t ifNil: [^ true].
t do: [:e |
e ~= defaultValue ifTrue: [^ false].
].
^ true.
!
----- Method: SparseLargeTable>>analyzeSpaceSaving (in category 'private') -----
analyzeSpaceSaving
| total elems tablesTotal nonNilTables |
total _ size - base + 1.
elems _ 0.
base to: size do: [:i | (self at: i) ~= defaultValue ifTrue: [elems _ elems + 1]].
tablesTotal _ self basicSize.
nonNilTables _ 0.
1 to: self basicSize do: [:i | (self basicAt: i) ifNotNil: [nonNilTables _ nonNilTables + 1]].
^ String streamContents: [:strm |
strm nextPutAll: 'total: '.
strm nextPutAll: total printString.
strm nextPutAll: ' elements: '.
strm nextPutAll: elems printString.
strm nextPutAll: ' tables: '.
strm nextPutAll: tablesTotal printString.
strm nextPutAll: ' non-nil: '.
strm nextPutAll: nonNilTables printString.
].
!
----- Method: SparseLargeTable>>arrayClass (in category 'accessing') -----
arrayClass
^(self basicAt: 1) class
!
----- Method: SparseLargeTable>>at: (in category 'accessing') -----
at: index
self pvtCheckIndex: index.
^self noCheckAt: index.
!
----- Method: SparseLargeTable>>at:put: (in category 'accessing') -----
at: index put: value
self pvtCheckIndex: index.
^self noCheckAt: index put: value
!
----- Method: SparseLargeTable>>base (in category 'accessing') -----
base
^ base.
!
----- Method: SparseLargeTable>>chunkSize (in category 'accessing') -----
chunkSize
^chunkSize
!
----- Method: SparseLargeTable>>copyEmpty (in category 'private') -----
copyEmpty
"Answer a copy of the receiver that contains no elements."
^self speciesNew: 0
!
----- Method: SparseLargeTable>>findLastNonNilSubTable (in category 'private') -----
findLastNonNilSubTable
(self basicAt: self basicSize) ifNotNil: [^ self basicSize].
self basicSize - 1 to: 1 by: -1 do: [:lastIndex |
(self basicAt: lastIndex) ifNotNil: [^ lastIndex].
].
^ 0.
!
----- Method: SparseLargeTable>>initChunkSize:size:arrayClass:base:defaultValue: (in category 'initialization') -----
initChunkSize: aChunkSize size: aSize arrayClass: aClass base: b defaultValue: d
| lastChunkSize |
chunkSize := aChunkSize.
size := aSize.
base _ b.
defaultValue _ d.
1 to: (self basicSize - 1) do: [ :in | self basicAt: in put: (aClass new: chunkSize withAll: defaultValue) ].
lastChunkSize := size \\ chunkSize.
lastChunkSize = 0 ifTrue: [lastChunkSize := chunkSize].
size = 0
ifTrue: [self basicAt: 1 put: (aClass new: 0)]
ifFalse: [self basicAt: self basicSize put: (aClass new: lastChunkSize withAll: defaultValue)].
!
----- Method: SparseLargeTable>>noCheckAt: (in category 'accessing') -----
noCheckAt: index
| chunkIndex t |
chunkIndex := index - base // chunkSize + 1.
(chunkIndex > self basicSize or: [chunkIndex < 1]) ifTrue: [^ defaultValue].
t _ self basicAt: chunkIndex.
t ifNil: [^ defaultValue].
^ t at: (index - base + 1 - (chunkIndex - 1 * chunkSize))
!
----- Method: SparseLargeTable>>noCheckAt:put: (in category 'accessing') -----
noCheckAt: index put: value
| chunkIndex t |
chunkIndex := index - base // chunkSize + 1.
chunkIndex > self basicSize ifTrue: [^ value].
t _ self basicAt: chunkIndex.
t ifNil: [^ value].
^ t at: (index - base + 1 - (chunkIndex - 1 * chunkSize)) put: value
!
----- Method: SparseLargeTable>>printElementsOn: (in category 'printing') -----
printElementsOn: aStream
| element |
aStream nextPut: $(.
base to: size do: [:index | element _ self at: index. aStream print: element; space].
self isEmpty ifFalse: [aStream skip: -1].
aStream nextPut: $)
!
----- Method: SparseLargeTable>>printOn: (in category 'printing') -----
printOn: aStream
(#(String) includes: self arrayClass name)
ifTrue: [^self storeOn: aStream].
^super printOn: aStream
!
----- Method: SparseLargeTable>>privateSize: (in category 'private') -----
privateSize: s
size _ s.
!
----- Method: SparseLargeTable>>pvtCheckIndex: (in category 'private') -----
pvtCheckIndex: index
index isInteger ifFalse: [self errorNonIntegerIndex].
index < 1 ifTrue: [self errorSubscriptBounds: index].
index > size ifTrue: [self errorSubscriptBounds: index].
!
----- Method: SparseLargeTable>>similarInstance (in category 'private') -----
similarInstance
^self class
new: self size
chunkSize: self chunkSize
arrayClass: self arrayClass
!
----- Method: SparseLargeTable>>similarInstance: (in category 'private') -----
similarInstance: newSize
^self class
new: newSize
chunkSize: self chunkSize
arrayClass: self arrayClass
!
----- Method: SparseLargeTable>>similarSpeciesInstance (in category 'private') -----
similarSpeciesInstance
^self similarInstance
!
----- Method: SparseLargeTable>>similarSpeciesInstance: (in category 'private') -----
similarSpeciesInstance: newSize
^self similarInstance: newSize
!
----- Method: SparseLargeTable>>size (in category 'accessing') -----
size
^size
!
----- Method: SparseLargeTable>>speciesNew (in category 'private') -----
speciesNew
^self species
new: self size
chunkSize: self chunkSize
arrayClass: self arrayClass
!
----- Method: SparseLargeTable>>speciesNew: (in category 'private') -----
speciesNew: newSize
^self species
new: newSize
chunkSize: self chunkSize
arrayClass: self arrayClass
!
----- Method: SparseLargeTable>>storeOn: (in category 'printing') -----
storeOn: aStream
| x |
(#(String) includes: self arrayClass name) ifTrue:
[aStream nextPut: $'.
1 to: self size do:
[:i |
aStream nextPut: (x _ self at: i).
x == $' ifTrue: [aStream nextPut: x]].
aStream nextPutAll: ''' asLargeArrayChunkSize: '.
aStream nextPutAll: self chunkSize asString.
^self].
^super storeOn: aStream
!
----- Method: SparseLargeTable>>zapDefaultOnlyEntries (in category 'accessing') -----
zapDefaultOnlyEntries
| lastIndex newInst |
1 to: self basicSize do: [:i |
(self allDefaultValueSubtableAt: i) ifTrue: [self basicAt: i put: nil].
].
lastIndex _ self findLastNonNilSubTable.
lastIndex = 0 ifTrue: [^ self].
newInst _ self class new: lastIndex*chunkSize chunkSize: chunkSize arrayClass: (self basicAt: lastIndex) class base: base defaultValue: defaultValue.
newInst privateSize: self size.
base to: newInst size do: [:i | newInst at: i put: (self at: i)].
1 to: newInst basicSize do: [:i |
(newInst allDefaultValueSubtableAt: i) ifTrue: [newInst basicAt: i put: nil].
].
" this is not allowed in production: self becomeForward: newInst. "
^ newInst.
!
ArrayedCollection subclass: #String
instanceVariableNames: ''
classVariableNames: 'AsciiOrder CaseInsensitiveOrder CaseSensitiveOrder CSLineEnders CSNonSeparators CSSeparators HtmlEntities LowercasingTable Tokenish UppercasingTable'
poolDictionaries: ''
category: 'Collections-Strings'!
!String commentStamp: '<historical>' prior: 0!
A String is an indexed collection of Characters. Class String provides the abstract super class for ByteString (that represents an array of 8-bit Characters) and WideString (that represents an array of 32-bit characters). In the similar manner of LargeInteger and SmallInteger, those subclasses are chosen accordingly for a string; namely as long as the system can figure out so, the String is used to represent the given string.
Strings support a vast array of useful methods, which can best be learned by browsing and trying out examples as you find them in the code.
Here are a few useful methods to look at...
String match:
String contractTo:
String also inherits many useful methods from its hierarchy, such as
SequenceableCollection ,
SequenceableCollection copyReplaceAll:with:
!
String variableByteSubclass: #ByteString
instanceVariableNames: ''
classVariableNames: 'Latin1ToUtf8Encodings Latin1ToUtf8Map'
poolDictionaries: ''
category: 'Collections-Strings'!
!ByteString commentStamp: '<historical>' prior: 0!
This class represents the array of 8 bit wide characters.
!
----- Method: ByteString class>>compare:with:collated: (in category 'primitives') -----
compare: string1 with: string2 collated: order
"Return 1, 2 or 3, if string1 is <, =, or > string2, with the collating order of characters given by the order array."
| len1 len2 c1 c2 |
<primitive: 'primitiveCompareString' module: 'MiscPrimitivePlugin'>
self var: #string1 declareC: 'unsigned char *string1'.
self var: #string2 declareC: 'unsigned char *string2'.
self var: #order declareC: 'unsigned char *order'.
len1 _ string1 size.
len2 _ string2 size.
1 to: (len1 min: len2) do:
[:i |
c1 _ order at: (string1 basicAt: i) + 1.
c2 _ order at: (string2 basicAt: i) + 1.
c1 = c2 ifFalse:
[c1 < c2 ifTrue: [^ 1] ifFalse: [^ 3]]].
len1 = len2 ifTrue: [^ 2].
len1 < len2 ifTrue: [^ 1] ifFalse: [^ 3].
!
----- Method: ByteString class>>findFirstInString:inSet:startingAt: (in category 'primitives') -----
findFirstInString: aString inSet: inclusionMap startingAt: start
| i stringSize |
<primitive: 'primitiveFindFirstInString' module: 'MiscPrimitivePlugin'>
self var: #aString declareC: 'unsigned char *aString'.
self var: #inclusionMap declareC: 'char *inclusionMap'.
inclusionMap size ~= 256 ifTrue: [ ^0 ].
i _ start.
stringSize _ aString size.
[ i <= stringSize and: [ (inclusionMap at: (aString at: i) asciiValue+1) = 0 ] ] whileTrue: [
i _ i + 1 ].
i > stringSize ifTrue: [ ^0 ].
^i!
----- Method: ByteString class>>indexOfAscii:inString:startingAt: (in category 'primitives') -----
indexOfAscii: anInteger inString: aString startingAt: start
| stringSize |
<primitive: 'primitiveIndexOfAsciiInString' module: 'MiscPrimitivePlugin'>
self var: #aCharacter declareC: 'int anInteger'.
self var: #aString declareC: 'unsigned char *aString'.
stringSize _ aString size.
start to: stringSize do: [:pos |
(aString at: pos) asciiValue = anInteger ifTrue: [^ pos]].
^ 0
!
----- Method: ByteString class>>initialize (in category 'initialization') -----
initialize
"ByteString initialize"
| latin1 utf8 |
Latin1ToUtf8Map := ByteArray new: 256.
Latin1ToUtf8Encodings := Array new: 256.
0 to: 255 do:[:i|
latin1 := String with: (Character value: i).
utf8 := latin1 convertToWithConverter: UTF8TextConverter new.
latin1 = utf8 ifTrue:[
Latin1ToUtf8Map at: i+1 put: 0. "no translation needed"
] ifFalse:[
Latin1ToUtf8Map at: i+1 put: 1. "no translation needed"
Latin1ToUtf8Encodings at: i+1 put: utf8.
].
].!
----- Method: ByteString class>>stringHash:initialHash: (in category 'primitives') -----
stringHash: aString initialHash: speciesHash
| stringSize hash low |
<primitive: 'primitiveStringHash' module: 'MiscPrimitivePlugin'>
self var: #aHash declareC: 'int speciesHash'.
self var: #aString declareC: 'unsigned char *aString'.
stringSize _ aString size.
hash _ speciesHash bitAnd: 16rFFFFFFF.
1 to: stringSize do: [:pos |
hash _ hash + (aString at: pos) asciiValue.
"Begin hashMultiply"
low _ hash bitAnd: 16383.
hash _ (16r260D * low + ((16r260D * (hash bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384)) bitAnd: 16r0FFFFFFF.
].
^ hash!
----- Method: ByteString class>>translate:from:to:table: (in category 'primitives') -----
translate: aString from: start to: stop table: table
"translate the characters in the string by the given table, in place"
<primitive: 'primitiveTranslateStringWithTable' module: 'MiscPrimitivePlugin'>
self var: #table declareC: 'unsigned char *table'.
self var: #aString declareC: 'unsigned char *aString'.
start to: stop do: [ :i |
aString at: i put: (table at: (aString at: i) asciiValue+1) ]!
----- Method: ByteString>>asByteArray (in category 'converting') -----
asByteArray
| ba sz |
sz := self byteSize.
ba := ByteArray new: sz.
ba replaceFrom: 1 to: sz with: self startingAt: 1.
^ba!
----- Method: ByteString>>asOctetString (in category 'converting') -----
asOctetString
^ self.
!
----- Method: ByteString>>at: (in category '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)!
----- Method: ByteString>>at:put: (in category 'accessing') -----
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 isCharacter
ifFalse:[^self errorImproperStore].
aCharacter isOctetCharacter ifFalse:[
"Convert to WideString"
self becomeForward: (WideString from: self).
^self at: index put: aCharacter.
].
index isInteger
ifTrue: [self errorSubscriptBounds: index]
ifFalse: [self errorNonIntegerIndex]!
----- Method: ByteString>>byteAt: (in category 'accessing') -----
byteAt: index
<primitive: 60>
^(self at: index) asciiValue!
----- Method: ByteString>>byteAt:put: (in category 'accessing') -----
byteAt: index put: value
<primitive: 61>
self at: index put: value asCharacter.
^value!
----- Method: ByteString>>byteSize (in category 'accessing') -----
byteSize
^self size!
----- Method: ByteString>>convertFromCompoundText (in category 'converting') -----
convertFromCompoundText
| readStream writeStream converter |
readStream _ self readStream.
writeStream _ String new writeStream.
converter _ CompoundTextConverter new.
converter ifNil: [^ self].
[readStream atEnd] whileFalse: [
writeStream nextPut: (converter nextFromStream: readStream)].
^ writeStream contents
!
----- Method: ByteString>>convertFromSystemString (in category 'converting') -----
convertFromSystemString
| readStream writeStream converter |
readStream _ self readStream.
writeStream _ String new writeStream.
converter _ LanguageEnvironment defaultSystemConverter.
converter ifNil: [^ self].
[readStream atEnd] whileFalse: [
writeStream nextPut: (converter nextFromStream: readStream)].
^ writeStream contents
!
----- Method: ByteString>>findSubstring:in:startingAt:matchTable: (in category 'comparing') -----
findSubstring: key in: body startingAt: start matchTable: matchTable
"self assert: ('i' beginsWith: 20999017 asCharacter asString) not"
"self assert: (((String newFrom: {20999017 asCharacter. 20983887
asCharacter}) beginsWith: 20999017 asCharacter asString))"
^ key isByteString
ifTrue: [self
primitiveFindSubstring: key
in: body
startingAt: start
matchTable: matchTable]
ifFalse: [super
findSubstring: key
in: body
startingAt: start
matchTable: matchTable]!
----- Method: ByteString>>isByteString (in category 'testing') -----
isByteString
"Answer whether the receiver is a ByteString"
^true!
----- Method: ByteString>>isOctetString (in category 'testing') -----
isOctetString
"Answer whether the receiver can be represented as a byte string.
This is different from asking whether the receiver *is* a ByteString
(i.e., #isByteString)"
^ true.
!
----- Method: ByteString>>primitiveFindSubstring:in:startingAt:matchTable: (in category 'comparing') -----
primitiveFindSubstring: key in: body startingAt: start matchTable: matchTable
"Answer the index in the string body at which the substring key first occurs, at or beyond start. The match is determined using matchTable, which can be used to effect, eg, case-insensitive matches. If no match is found, zero will be returned.
The algorithm below is not optimum -- it is intended to be translated to C which will go so fast that it wont matter."
| index |
<primitive: 'primitiveFindSubstring' module: 'MiscPrimitivePlugin'>
self var: #key declareC: 'unsigned char *key'.
self var: #body declareC: 'unsigned char *body'.
self var: #matchTable declareC: 'unsigned char *matchTable'.
key size = 0 ifTrue: [^ 0].
start to: body size - key size + 1 do:
[:startIndex |
index _ 1.
[(matchTable at: (body at: startIndex+index-1) asciiValue + 1)
= (matchTable at: (key at: index) asciiValue + 1)]
whileTrue:
[index = key size ifTrue: [^ startIndex].
index _ index+1]].
^ 0
"
' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 1 matchTable: CaseSensitiveOrder 1
' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 2 matchTable: CaseSensitiveOrder 7
' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 8 matchTable: CaseSensitiveOrder 0
' ' findSubstring: 'abc' in: 'abcdefABcd' startingAt: 2 matchTable: CaseSensitiveOrder 0
' ' findSubstring: 'abc' in: 'abcdefABcd' startingAt: 2 matchTable: CaseInsensitiveOrder 7
"!
----- Method: ByteString>>replaceFrom:to:with:startingAt: (in category 'accessing') -----
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>
replacement class == WideString ifTrue: [
self becomeForward: (WideString from: self).
].
super replaceFrom: start to: stop with: replacement startingAt: repStart.
!
----- Method: ByteString>>squeakToUtf8 (in category 'converting') -----
squeakToUtf8
"Convert the given string from UTF-8 using the fast path if converting to Latin-1"
| outStream lastIndex nextIndex |
Latin1ToUtf8Map ifNil:[^super squeakToUtf8]. "installation guard"
lastIndex := 1.
nextIndex := ByteString findFirstInString: self inSet: Latin1ToUtf8Map startingAt: lastIndex.
nextIndex = 0 ifTrue:[^self].
outStream := (String new: self size * 2) writeStream.
[outStream next: nextIndex-lastIndex putAll: self startingAt: lastIndex.
outStream nextPutAll: (Latin1ToUtf8Encodings at: (self byteAt: nextIndex)+1).
lastIndex := nextIndex + 1.
nextIndex := ByteString findFirstInString: self inSet: Latin1ToUtf8Map startingAt: lastIndex.
nextIndex = 0] whileFalse.
outStream next: self size-lastIndex+1 putAll: self startingAt: lastIndex.
^outStream contents
!
----- Method: ByteString>>utf8ToSqueak (in category 'converting') -----
utf8ToSqueak
"Convert the given string from UTF-8 using the fast path if converting to Latin-1"
| outStream lastIndex nextIndex byte1 byte2 byte3 byte4 unicode |
Latin1ToUtf8Map ifNil:[^super utf8ToSqueak]. "installation guard"
lastIndex := 1.
nextIndex := ByteString findFirstInString: self inSet: Latin1ToUtf8Map startingAt: lastIndex.
nextIndex = 0 ifTrue:[^self].
outStream := (String new: self size) writeStream.
[outStream next: nextIndex-lastIndex putAll: self startingAt: lastIndex.
byte1 := self byteAt: nextIndex.
(byte1 bitAnd: 16rE0) = 192 ifTrue: [ "two bytes"
byte2 := self byteAt: (nextIndex := nextIndex+1).
(byte2 bitAnd: 16rC0) = 16r80 ifFalse:[self error: 'Invalid UTF-8 input'].
unicode := ((byte1 bitAnd: 31) bitShift: 6) + (byte2 bitAnd: 63)].
(byte1 bitAnd: 16rF0) = 224 ifTrue: [ "three bytes"
byte2 := self byteAt: (nextIndex := nextIndex+1).
(byte2 bitAnd: 16rC0) = 16r80 ifFalse:[self error: 'Invalid UTF-8 input'].
byte3 := self byteAt: (nextIndex := nextIndex+1).
(byte3 bitAnd: 16rC0) = 16r80 ifFalse:[self error: 'Invalid UTF-8 input'].
unicode := ((byte1 bitAnd: 15) bitShift: 12) + ((byte2 bitAnd: 63) bitShift: 6)
+ (byte3 bitAnd: 63)].
(byte1 bitAnd: 16rF8) = 240 ifTrue: [ "four bytes"
byte2 := self byteAt: (nextIndex := nextIndex+1).
(byte2 bitAnd: 16rC0) = 16r80 ifFalse:[self error: 'Invalid UTF-8 input'].
byte3 := self byteAt: (nextIndex := nextIndex+1).
(byte3 bitAnd: 16rC0) = 16r80 ifFalse:[self error: 'Invalid UTF-8 input'].
byte4 := self byteAt: (nextIndex := nextIndex+1).
(byte4 bitAnd: 16rC0) = 16r80 ifFalse:[self error: 'Invalid UTF-8 input'].
unicode := ((byte1 bitAnd: 16r7) bitShift: 18) +
((byte2 bitAnd: 63) bitShift: 12) +
((byte3 bitAnd: 63) bitShift: 6) +
(byte4 bitAnd: 63)].
unicode ifNil:[self error: 'Invalid UTF-8 input'].
outStream nextPut: (Character value: unicode).
lastIndex := nextIndex + 1.
nextIndex := ByteString findFirstInString: self inSet: Latin1ToUtf8Map startingAt: lastIndex.
nextIndex = 0] whileFalse.
outStream next: self size-lastIndex+1 putAll: self startingAt: lastIndex.
^outStream contents
!
----- Method: String class>>ccg:prolog:expr:index: (in category 'plugin generation') -----
ccg: cg prolog: aBlock expr: aString index: anInteger
^cg
ccgLoad: aBlock
expr: aString
asCharPtrFrom: anInteger
andThen: (cg ccgValBlock: 'isBytes')
!
----- Method: String class>>ccgDeclareCForVar: (in category 'plugin generation') -----
ccgDeclareCForVar: aSymbolOrString
^'char *', aSymbolOrString
!
----- Method: String class>>compare:with:collated: (in category 'primitives') -----
compare: string1 with: string2 collated: order
"Return 1, 2 or 3, if string1 is <, =, or > string2, with the collating order of characters given by the order array."
| len1 len2 c1 c2 |
order == nil ifTrue: [
len1 _ string1 size.
len2 _ string2 size.
1 to: (len1 min: len2) do:[:i |
c1 _ (string1 at: i) asInteger.
c2 _ (string2 at: i) asInteger.
c1 = c2 ifFalse: [c1 < c2 ifTrue: [^ 1] ifFalse: [^ 3]].
].
len1 = len2 ifTrue: [^ 2].
len1 < len2 ifTrue: [^ 1] ifFalse: [^ 3].
].
len1 _ string1 size.
len2 _ string2 size.
1 to: (len1 min: len2) do:[:i |
c1 _ (string1 at: i) asInteger.
c2 _ (string2 at: i) asInteger.
c1 < 256 ifTrue: [c1 _ order at: c1 + 1].
c2 < 256 ifTrue: [c2 _ order at: c2 + 1].
c1 = c2 ifFalse:[c1 < c2 ifTrue: [^ 1] ifFalse: [^ 3]].
].
len1 = len2 ifTrue: [^ 2].
len1 < len2 ifTrue: [^ 1] ifFalse: [^ 3].
!
----- Method: String class>>cr (in category 'instance creation') -----
cr
"Answer a string containing a single carriage return character."
^ self with: Character cr
!
----- Method: String class>>crlf (in category 'instance creation') -----
crlf
"Answer a string containing a carriage return and a linefeed."
^ self with: Character cr with: Character lf
!
----- Method: String class>>crlfcrlf (in category 'instance creation') -----
crlfcrlf
^self crlf , self crlf.
!
----- Method: String class>>example (in category '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!
----- Method: String class>>findFirstInString:inSet:startingAt: (in category 'primitives') -----
findFirstInString: aString inSet: inclusionMap startingAt: start
"Trivial, non-primitive version"
| i stringSize ascii more |
inclusionMap size ~= 256 ifTrue: [^ 0].
stringSize _ aString size.
more _ true.
i _ start - 1.
[more and: [i + 1 <= stringSize]] whileTrue: [
i _ i + 1.
ascii _ (aString at: i) asciiValue.
more _ ascii < 256 ifTrue: [(inclusionMap at: ascii + 1) = 0] ifFalse: [true].
].
i + 1 > stringSize ifTrue: [^ 0].
^ i!
----- Method: String class>>fromByteArray: (in category 'instance creation') -----
fromByteArray: aByteArray
^ aByteArray asString
!
----- Method: String class>>fromPacked: (in category 'instance creation') -----
fromPacked: aLong
"Convert from a longinteger to a String of length 4."
| s |
s _ self new: 4.
s at: 1 put: (aLong digitAt: 4) asCharacter.
s at: 2 put: (aLong digitAt: 3) asCharacter.
s at: 3 put: (aLong digitAt: 2) asCharacter.
s at: 4 put: (aLong digitAt: 1) asCharacter.
^s
"String fromPacked: 'TEXT' asPacked"
!
----- Method: String class>>fromString: (in category 'instance creation') -----
fromString: aString
"Answer an instance of me that is a copy of the argument, aString."
^ aString copyFrom: 1 to: aString size!
----- Method: String class>>indexOfAscii:inString:startingAt: (in category 'primitives') -----
indexOfAscii: anInteger inString: aString startingAt: start
"Trivial, non-primitive version"
| stringSize |
stringSize _ aString size.
start to: stringSize do: [:pos |
(aString at: pos) asInteger = anInteger ifTrue: [^ pos]].
^ 0
!
----- Method: String class>>initialize (in category 'initialization') -----
initialize "self initialize"
| order |
AsciiOrder _ (0 to: 255) as: ByteArray.
CaseInsensitiveOrder _ AsciiOrder copy.
($a to: $z) do:
[:c | CaseInsensitiveOrder at: c asciiValue + 1
put: (CaseInsensitiveOrder at: c asUppercase asciiValue +1)].
"Case-sensitive compare sorts space, digits, letters, all the rest..."
CaseSensitiveOrder _ ByteArray new: 256 withAll: 255.
order _ -1.
' 0123456789' do: "0..10"
[:c | CaseSensitiveOrder at: c asciiValue + 1 put: (order _ order+1)].
($a to: $z) do: "11-64"
[:c | CaseSensitiveOrder at: c asUppercase asciiValue + 1 put: (order _ order+1).
CaseSensitiveOrder at: c asciiValue + 1 put: (order _ order+1)].
1 to: CaseSensitiveOrder size do:
[:i | (CaseSensitiveOrder at: i) = 255 ifTrue:
[CaseSensitiveOrder at: i put: (order _ order+1)]].
order = 255 ifFalse: [self error: 'order problem'].
"a table for translating to lower case"
LowercasingTable _ String withAll: (Character allByteCharacters collect: [:c | c asLowercase]).
"a table for translating to upper case"
UppercasingTable _ String withAll: (Character allByteCharacters collect: [:c | c asUppercase]).
"a table for testing tokenish (for fast numArgs)"
Tokenish _ String withAll: (Character allByteCharacters collect:
[:c | c tokenish ifTrue: [c] ifFalse: [$~]]).
"CR and LF--characters that terminate a line"
CSLineEnders _ CharacterSet empty.
CSLineEnders add: Character cr.
CSLineEnders add: Character lf.
"separators and non-separators"
CSSeparators _ CharacterSet separators.
CSNonSeparators _ CSSeparators complement.!
----- Method: String class>>initializeHtmlEntities (in category 'initialization') -----
initializeHtmlEntities
"self initializeHtmlEntities"
HtmlEntities _ (Dictionary new: 128)
at: 'amp' put: $&;
at: 'lt' put: $<;
at: 'gt' put: $>;
at: 'quot' put: $";
at: 'euro' put: Character euro;
yourself.
#('nbsp' 'iexcl' 'cent' 'pound' 'curren' 'yen' 'brvbar' 'sect' 'uml' 'copy' 'ordf' 'laquo' 'not' 'shy' 'reg' 'hibar' 'deg' 'plusmn' 'sup2' 'sup3' 'acute' 'micro' 'para' 'middot' 'cedil' 'sup1' 'ordm' 'raquo' 'frac14' 'frac12' 'frac34' 'iquest' 'Agrave' 'Aacute' 'Acirc' 'Atilde' 'Auml' 'Aring' 'AElig' 'Ccedil' 'Egrave' 'Eacute' 'Ecirc' 'Euml' 'Igrave' 'Iacute' 'Icirc' 'Iuml' 'ETH' 'Ntilde' 'Ograve' 'Oacute' 'Ocirc' 'Otilde' 'Ouml' 'times' 'Oslash' 'Ugrave' 'Uacute' 'Ucirc' 'Uuml' 'Yacute' 'THORN' 'szlig' 'agrave' 'aacute' 'acirc' 'atilde' 'auml' 'aring' 'aelig' 'ccedil' 'egrave' 'eacute' 'ecirc' 'euml' 'igrave' 'iacute' 'icirc' 'iuml' 'eth' 'ntilde' 'ograve' 'oacute' 'ocirc' 'otilde' 'ouml' 'divide' 'oslash' 'ugrave' 'uacute' 'ucirc' 'uuml' 'yacute' 'thorn' 'yuml' ) withIndexDo: [:each :index | HtmlEntities at: each put: (index + 159) asCharacter]!
----- Method: String class>>lf (in category 'instance creation') -----
lf
"Answer a string containing a single carriage return character."
^ self with: Character lf!
----- Method: String class>>new: (in category 'instance creation') -----
new: sizeRequested
"Answer an instance of this class with the number of indexable
variables specified by the argument, sizeRequested."
self == String
ifTrue:[^ByteString new: sizeRequested]
ifFalse:[^self basicNew: sizeRequested].!
----- Method: String class>>readFrom: (in category 'instance creation') -----
readFrom: inStream
"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: (self 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!
----- Method: String class>>stringHash:initialHash: (in category 'primitives') -----
stringHash: aString initialHash: speciesHash
| stringSize hash low |
stringSize _ aString size.
hash _ speciesHash bitAnd: 16rFFFFFFF.
1 to: stringSize do: [:pos |
hash _ hash + (aString at: pos) asInteger.
"Begin hashMultiply"
low _ hash bitAnd: 16383.
hash _ (16r260D * low + ((16r260D * (hash bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384)) bitAnd: 16r0FFFFFFF.
].
^ hash.
!
----- Method: String class>>tab (in category 'instance creation') -----
tab
"Answer a string containing a single tab character."
^ self with: Character tab
!
----- Method: String class>>translate:from:to:table: (in category 'primitives') -----
translate: aString from: start to: stop table: table
"Trivial, non-primitive version"
| char |
start to: stop do: [:i |
char _ (aString at: i) asInteger.
char < 256 ifTrue: [aString at: i put: (table at: char+1)].
].
!
----- Method: String class>>value: (in category 'instance creation') -----
value: anInteger
^ self with: (Character value: anInteger).
!
----- Method: String class>>with: (in category 'instance creation') -----
with: aCharacter
| newCollection |
aCharacter asInteger < 256
ifTrue:[newCollection _ ByteString new: 1]
ifFalse:[newCollection _ WideString new: 1].
newCollection at: 1 put: aCharacter.
^newCollection!
----- Method: String>>* (in category 'arithmetic') -----
* arg
^ arg adaptToString: self andSend: #*!
----- Method: String>>+ (in category 'arithmetic') -----
+ arg
^ arg adaptToString: self andSend: #+!
----- Method: String>>- (in category 'arithmetic') -----
- arg
^ arg adaptToString: self andSend: #-!
----- Method: String>>/ (in category 'arithmetic') -----
/ arg
^ arg adaptToString: self andSend: #/!
----- Method: String>>// (in category 'arithmetic') -----
// arg
^ arg adaptToString: self andSend: #//!
----- Method: String>>< (in category 'comparing') -----
< aString
"Answer whether the receiver sorts before aString.
The collation order is simple ascii (with case differences)."
^(self compare: aString caseSensitive: true) = 1!
----- Method: String>><= (in category 'comparing') -----
<= aString
"Answer whether the receiver sorts before or equal to aString.
The collation order is simple ascii (with case differences)."
^(self compare: aString caseSensitive: true) <= 2!
----- Method: String>>= (in category 'comparing') -----
= aString
"Answer whether the receiver sorts equally as aString.
The collation order is simple ascii (with case differences)."
aString isString ifFalse:[^false].
^(self compare: aString caseSensitive: true) = 2!
----- Method: String>>> (in category 'comparing') -----
> aString
"Answer whether the receiver sorts after aString.
The collation order is simple ascii (with case differences)."
^(self compare: aString caseSensitive: true) = 3!
----- Method: String>>>= (in category 'comparing') -----
>= aString
"Answer whether the receiver sorts after or equal to aString.
The collation order is simple ascii (with case differences)."
^(self compare: aString caseSensitive: true) >= 2!
----- Method: String>>\\ (in category 'arithmetic') -----
\\ arg
^ arg adaptToString: self andSend: #\\!
----- Method: String>>adaptToCollection:andSend: (in category 'converting') -----
adaptToCollection: rcvr andSend: selector
"If I am involved in arithmetic with a collection, convert me to a number."
^ rcvr perform: selector with: self asNumber!
----- Method: String>>adaptToNumber:andSend: (in category 'converting') -----
adaptToNumber: rcvr andSend: selector
"If I am involved in arithmetic with a number, convert me to a number."
^ rcvr perform: selector with: self asNumber!
----- Method: String>>adaptToPoint:andSend: (in category 'converting') -----
adaptToPoint: rcvr andSend: selector
"If I am involved in arithmetic with a point, convert me to a number."
^ rcvr perform: selector with: self asNumber!
----- Method: String>>adaptToString:andSend: (in category 'converting') -----
adaptToString: rcvr andSend: selector
"If I am involved in arithmetic with a string, convert us both to
numbers, and return the printString of the result."
^ (rcvr asNumber perform: selector with: self asNumber) printString!
----- Method: String>>alike: (in category 'comparing') -----
alike: aString
"Answer some indication of how alike the receiver is to the argument, 0 is no match, twice aString size is best score. Case is ignored."
| i j k minSize bonus |
minSize _ (j _ self size) min: (k _ aString size).
bonus _ (j - k) abs < 2 ifTrue: [ 1 ] ifFalse: [ 0 ].
i _ 1.
[(i <= minSize) and: [((super at: i) bitAnd: 16rDF) = ((aString at: i) asciiValue bitAnd: 16rDF)]]
whileTrue: [ i _ i + 1 ].
[(j > 0) and: [(k > 0) and:
[((super at: j) bitAnd: 16rDF) = ((aString at: k) asciiValue bitAnd: 16rDF)]]]
whileTrue: [ j _ j - 1. k _ k - 1. ].
^ i - 1 + self size - j + bonus. !
----- Method: String>>asByteArray (in category 'converting') -----
asByteArray
"Convert to a ByteArray with the ascii values of the string."
| b |
b _ ByteArray new: self byteSize.
1 to: self size * 4 do: [:i |
b at: i put: (self byteAt: i).
].
^ b.
!
----- Method: String>>asByteString (in category 'converting') -----
asByteString
"Convert the receiver into a ByteString"
^self asOctetString!
----- Method: String>>asCharacter (in category 'converting') -----
asCharacter
"Answer the receiver's first character, or '*' if none. Idiosyncratic, provisional."
^ self size > 0 ifTrue: [self first] ifFalse:[$·]!
----- Method: String>>asDate (in category 'converting') -----
asDate
"Many allowed forms, see Date>>#readFrom:"
^ Date fromString: self!
----- Method: String>>asDateAndTime (in category 'converting') -----
asDateAndTime
"Convert from UTC format" ^ DateAndTime fromString: self!
----- Method: String>>asDefaultDecodedString (in category 'converting') -----
asDefaultDecodedString
^ self
!
----- Method: String>>asDisplayText (in category 'converting') -----
asDisplayText
"Answer a DisplayText whose text string is the receiver."
^DisplayText text: self asText!
----- Method: String>>asDuration (in category 'converting') -----
asDuration
"convert from [nnnd]hh:mm:ss[.nanos] format. [] implies optional elements"
^ Duration fromString: self
!
----- Method: String>>asExplorerString (in category 'user interface') -----
asExplorerString
^ self asString!
----- Method: String>>asFileName (in category 'converting') -----
asFileName
"Answer a String made up from the receiver that is an acceptable file
name."
| string checkedString |
string _ FileDirectory checkName: self fixErrors: true.
checkedString _ (FilePath pathName: string) asVmPathName.
^ (FilePath pathName: checkedString isEncoded: true) asSqueakPathName.
!
----- Method: String>>asFourCode (in category 'converting') -----
asFourCode
| result |
self size = 4 ifFalse: [^self error: 'must be exactly four characters'].
result _ self inject: 0 into: [:val :each | 256 * val + each asciiValue].
(result bitAnd: 16r80000000) = 0
ifFalse: [self error: 'cannot resolve fourcode'].
(result bitAnd: 16r40000000) = 0 ifFalse: [^result - 16r80000000].
^ result
!
----- Method: String>>asHex (in category 'converting') -----
asHex
| stream |
stream _ WriteStream on: (String new: self size * 4).
self do: [ :ch | stream nextPutAll: ch hex ].
^stream contents!
----- Method: String>>asHtml (in category 'converting') -----
asHtml
"Do the basic character conversion for HTML. Leave all original return
and tabs in place, so can conver back by simply removing bracked
things. 4/4/96 tk"
| temp |
temp _ self copyReplaceAll: '&' with: '&'.
HtmlEntities keysAndValuesDo:
[:entity :char |
char = $& ifFalse:
[temp _ temp copyReplaceAll: char asString with: '&' , entity , ';']].
temp _ temp copyReplaceAll: ' ' with: ' <IMG SRC="tab.gif" ALT=" ">'.
temp _ temp copyReplaceAll: '
' with: '
<BR>'.
^ temp
"
'A<&>B' asHtml
"!
----- Method: String>>asIRCLowercase (in category 'converting') -----
asIRCLowercase
"Answer a String made up from the receiver whose characters are all
lowercase, where 'lowercase' is by IRC's definition"
^self collect: [ :c | c asIRCLowercase ]!
----- Method: String>>asIdentifier: (in category 'converting') -----
asIdentifier: shouldBeCapitalized
"Return a legal identifier, with first character in upper case if shouldBeCapitalized is true, else lower case. This will always return a legal identifier, even for an empty string"
| aString firstChar firstLetterPosition |
aString _ self select: [:el | el isAlphaNumeric].
firstLetterPosition _ aString findFirst: [:ch | ch isLetter].
aString _ firstLetterPosition == 0
ifFalse:
[aString copyFrom: firstLetterPosition to: aString size]
ifTrue:
['a', aString].
firstChar _ shouldBeCapitalized ifTrue: [aString first asUppercase] ifFalse: [aString first asLowercase].
^ firstChar asString, (aString copyFrom: 2 to: aString size)
"
'234Fred987' asIdentifier: false
'235Fred987' asIdentifier: true
'' asIdentifier: true
'()87234' asIdentifier: false
'())z>=PPve889 U >' asIdentifier: false
"!
----- Method: String>>asInteger (in category 'converting') -----
asInteger
^self asSignedInteger
!
----- Method: String>>asIntegerIfAllDigits (in category 'converting') -----
asIntegerIfAllDigits
"If the receiver consists entirely of digits, answer the integer represented, else answer nil. Because of the all-digits requirement, a negative result is impossible."
^ self isAllDigits ifTrue: [self asNumber] ifFalse: [nil]
"
'123.4' asIntegerIfAllDigits
'2345678901234' asIntegerIfAllDigits
'-234' asIntegerIfAllDigits
'02398' asIntegerIfAllDigits
"!
----- Method: String>>asLegalSelector (in category 'converting') -----
asLegalSelector
| toUse |
toUse _ ''.
self do:
[:char | char isAlphaNumeric ifTrue: [toUse _ toUse copyWith: char]].
(self size == 0 or: [self first isLetter not])
ifTrue: [toUse _ 'v', toUse].
^ toUse withFirstCharacterDownshifted
"'234znak 43 ) 2' asLegalSelector"!
----- Method: String>>asLowercase (in category 'converting') -----
asLowercase
"Answer a String made up from the receiver whose characters are all
lowercase."
^ self copy asString translateToLowercase!
----- Method: String>>asLowercaseAlphabetic (in category 'converting') -----
asLowercaseAlphabetic
"Return a copy of the receiver from which all non-alphabetic chars have been removed"
^ self select: [:ch | ch isLetter] thenCollect: [:l | l asLowercase]
"
' ? abc 8/ d ' asLowercaseAlphabetic
"
!
----- Method: String>>asNumber (in category 'converting') -----
asNumber
"Answer the Number created by interpreting the receiver as the string
representation of a number."
^Number readFromString: self!
----- Method: String>>asOctetString (in category 'converting') -----
asOctetString
"Convert the receiver into an octet string"
| string |
string _ String new: self size.
1 to: self size do: [:i | string at: i put: (self at: i)].
^string!
----- Method: String>>asPacked (in category 'converting') -----
asPacked
"Convert to a longinteger that describes the string"
^ self inject: 0 into: [ :pack :next | pack _ pack * 256 + next asInteger ].!
----- Method: String>>asPangoAttributes (in category 'pango') -----
asPangoAttributes
^ Array new: 0.
!
----- Method: String>>asSignedInteger (in category 'converting') -----
asSignedInteger
"Returns the first signed integer it can find or nil."
| start stream |
start := self findFirst: [:char | char isDigit].
start isZero ifTrue: [^nil].
stream := (ReadStream on: self) position: start.
stream back = $- ifTrue: [stream back].
^Integer readFrom: stream!
----- Method: String>>asSmalltalkComment (in category 'converting') -----
asSmalltalkComment
"return this string, munged so that it can be treated as a comment in Smalltalk code. Quote marks are added to the beginning and end of the string, and whenever a solitary quote mark appears within the string, it is doubled"
^String streamContents: [ :str |
| quoteCount first |
str nextPut: $".
quoteCount := 0.
first := true.
self do: [ :char |
char = $"
ifTrue: [
first ifFalse: [
str nextPut: char.
quoteCount := quoteCount + 1 ] ]
ifFalse: [
quoteCount odd ifTrue: [
"add a quote to even the number of quotes in a row"
str nextPut: $" ].
quoteCount := 0.
str nextPut: char ].
first := false ].
quoteCount odd ifTrue: [
"check at the end"
str nextPut: $". ].
str nextPut: $".
].
!
----- Method: String>>asSqueakPathName (in category 'converting') -----
asSqueakPathName
^ self.
!
----- Method: String>>asString (in category 'converting') -----
asString
"Answer this string."
^ self
!
----- Method: String>>asStringOrText (in category 'converting') -----
asStringOrText
"Answer this string."
^ self
!
----- Method: String>>asSymbol (in category 'converting') -----
asSymbol
"Answer the unique Symbol whose characters are the characters of the
string."
^Symbol intern: self!
----- Method: String>>asText (in category 'converting') -----
asText
"Answer a Text whose string is the receiver."
^Text fromString: self!
----- Method: String>>asTime (in category 'converting') -----
asTime
"Many allowed forms, see Time>>readFrom:"
^ Time fromString: self.!
----- Method: String>>asTimeStamp (in category 'converting') -----
asTimeStamp
"Convert from obsolete TimeStamp format"
^ TimeStamp fromString: self!
----- Method: String>>asUnHtml (in category 'converting') -----
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."
| 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 <...><...>"
ifFalse: [(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: $&].
rest = 'deg' ifTrue: [out nextPut: $°].
rest = 'quot' ifTrue: [out nextPut: $"].
did = out position ifTrue: [
self error: 'unknown encoded HTML char'.
"Please add it to this method"]]
ifFalse: [out nextPut: char]].
].
^ out contents!
----- Method: String>>asUnsignedInteger (in category 'converting') -----
asUnsignedInteger
"Returns the first integer it can find or nil."
| start stream |
start := self findFirst: [:char | char isDigit].
start isZero ifTrue: [^nil].
stream := (ReadStream on: self) position: start - 1.
^Integer readFrom: stream!
----- Method: String>>asUppercase (in category 'converting') -----
asUppercase
"Answer a String made up from the receiver whose characters are all
uppercase."
^self copy asString translateToUppercase!
----- Method: String>>asUrl (in category 'converting') -----
asUrl
"convert to a Url"
"'http://www.cc.gatech.edu/' asUrl"
"msw://chaos.resnet.gatech.edu:9000/' asUrl"
^Url absoluteFromText: self!
----- Method: String>>asUrlRelativeTo: (in category 'converting') -----
asUrlRelativeTo: aUrl
^aUrl newFromRelativeText: self!
----- Method: String>>asVmPathName (in category 'converting') -----
asVmPathName
^ (FilePath pathName: self) asVmPathName.
!
----- Method: String>>asWideString (in category 'converting') -----
asWideString
self isWideString
ifTrue:[^self]
ifFalse:[^WideString from: self]!
----- Method: String>>askIfAddStyle:req: (in category 'converting') -----
askIfAddStyle: priorMethod req: requestor
^ self "we are a string with no text style"!
----- Method: String>>beginsWith: (in category 'comparing') -----
beginsWith: prefix
"Answer whether the receiver begins with the given prefix string.
The comparison is case-sensitive."
self size < prefix size ifTrue: [^ false].
^ (self findSubstring: prefix in: self startingAt: 1
matchTable: CaseSensitiveOrder) = 1
!
----- Method: String>>byteAt: (in category 'accessing') -----
byteAt: index
^self subclassResponsibility!
----- Method: String>>byteAt:put: (in category 'accessing') -----
byteAt: index put: value
^self subclassResponsibility!
----- Method: String>>byteEncode: (in category 'filter streaming') -----
byteEncode:aStream
^aStream writeString: self.
!
----- Method: String>>byteSize (in category 'accessing') -----
byteSize
^self subclassResponsibility!
----- Method: String>>capitalized (in category 'converting') -----
capitalized
"Return a copy with the first letter capitalized"
| cap |
self isEmpty ifTrue: [ ^self copy ].
cap _ self copy.
cap at: 1 put: (cap at: 1) asUppercase.
^ cap!
----- Method: String>>caseInsensitiveLessOrEqual: (in category 'comparing') -----
caseInsensitiveLessOrEqual: aString
"Answer whether the receiver sorts before or equal to aString.
The collation order is case insensitive."
^(self compare: aString caseSensitive: false) <= 2!
----- Method: String>>caseSensitiveLessOrEqual: (in category 'comparing') -----
caseSensitiveLessOrEqual: aString
"Answer whether the receiver sorts before or equal to aString.
The collation order is case sensitive."
^(self compare: aString caseSensitive: true) <= 2!
----- Method: String>>charactersExactlyMatching: (in category 'comparing') -----
charactersExactlyMatching: aString
"Do a character-by-character comparison between the receiver and aString. Return the index of the final character that matched exactly."
| count |
count _ self size min: aString size.
1 to: count do: [:i |
(self at: i) = (aString at: i) ifFalse: [
^ i - 1]].
^ count!
----- Method: String>>compare: (in category 'comparing') -----
compare: aString
"Answer a comparison code telling how the receiver sorts relative to aString:
1 - before
2 - equal
3 - after.
The collation sequence is ascii with case differences ignored.
To get the effect of a <= b, but ignoring case, use (a compare: b) <= 2."
^self compare: aString caseSensitive: false!
----- Method: String>>compare:caseSensitive: (in category 'comparing') -----
compare: aString caseSensitive: aBool
"Answer a comparison code telling how the receiver sorts relative to aString:
1 - before
2 - equal
3 - after.
"
| map |
map := aBool ifTrue:[CaseSensitiveOrder] ifFalse:[CaseInsensitiveOrder].
^self compare: self with: aString collated: map!
----- Method: String>>compare:with:collated: (in category 'comparing') -----
compare: string1 with: string2 collated: order
(string1 isByteString and: [string2 isByteString]) ifTrue: [
^ ByteString compare: string1 with: string2 collated: order
].
"Primitive does not fail properly right now"
^ String compare: string1 with: string2 collated: order
"
self assert: 'abc' = 'abc' asWideString.
self assert: 'abc' asWideString = 'abc'.
self assert: ((ByteArray with: 97 with: 0 with: 0 with: 0) asString ~= 'a000' asWideString).
self assert: ('a000' asWideString ~= (ByteArray with: 97 with: 0 with: 0 with: 0) asString).
self assert: ('abc' sameAs: 'aBc' asWideString).
self assert: ('aBc' asWideString sameAs: 'abc').
self assert: ((ByteArray with: 97 with: 0 with: 0 with: 0) asString sameAs: 'Abcd' asWideString) not.
self assert: ('a000' asWideString sameAs: (ByteArray with: 97 with: 0 with: 0 with: 0) asString) not.
"!
----- Method: String>>composeAccents (in category 'converting') -----
composeAccents
| stream |
stream _ UnicodeCompositionStream on: (String new: 16).
self do: [:e | stream nextPut: e].
^ stream contents.
!
----- Method: String>>compressWithTable: (in category 'converting') -----
compressWithTable: tokens
"Return a string with all substrings that occur in tokens replaced
by a character with ascii code = 127 + token index.
This will work best if tokens are sorted by size.
Assumes this string contains no characters > 127, or that they
are intentionally there and will not interfere with this process."
| str null finalSize start result ri c ts |
null _ Character value: 0.
str _ self copyFrom: 1 to: self size. "Working string will get altered"
finalSize _ str size.
tokens doWithIndex:
[:token :tIndex |
start _ 1.
[(start _ str findString: token startingAt: start) > 0]
whileTrue:
[ts _ token size.
((start + ts) <= str size
and: [(str at: start + ts) = $ and: [tIndex*2 <= 128]])
ifTrue: [ts _ token size + 1. "include training blank"
str at: start put: (Character value: tIndex*2 + 127)]
ifFalse: [str at: start put: (Character value: tIndex + 127)].
str at: start put: (Character value: tIndex + 127).
1 to: ts-1 do: [:i | str at: start+i put: null].
finalSize _ finalSize - (ts - 1).
start _ start + ts]].
result _ String new: finalSize.
ri _ 0.
1 to: str size do:
[:i | (c _ str at: i) = null ifFalse: [result at: (ri _ ri+1) put: c]].
^ result!
----- Method: String>>contractTo: (in category 'converting') -----
contractTo: smallSize
"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: '...'
"
'A clear but rather long-winded summary' contractTo: 18
"!
----- Method: String>>convertFromEncoding: (in category 'converting') -----
convertFromEncoding: encodingName
^self convertFromWithConverter: (TextConverter newForEncoding: encodingName)!
----- Method: String>>convertFromSuperSwikiServerString (in category 'converting') -----
convertFromSuperSwikiServerString
^self convertFromEncoding: 'shift_jis'!
----- Method: String>>convertFromWithConverter: (in category 'converting') -----
convertFromWithConverter: converter
| readStream writeStream c |
readStream _ self readStream.
writeStream _ String new writeStream.
converter ifNil: [^ self].
[readStream atEnd] whileFalse: [
c _ converter nextFromStream: readStream.
c ifNotNil: [writeStream nextPut: c] ifNil: [^ writeStream contents]
].
^ writeStream contents
!
----- Method: String>>convertToEncoding: (in category 'converting') -----
convertToEncoding: encodingName
^self convertToWithConverter: (TextConverter newForEncoding: encodingName).!
----- Method: String>>convertToSuperSwikiServerString (in category 'converting') -----
convertToSuperSwikiServerString
^self convertToEncoding: 'shift_jis'!
----- Method: String>>convertToSystemString (in category 'converting') -----
convertToSystemString
| readStream writeStream converter |
readStream _ self readStream.
writeStream _ String new writeStream.
converter _ LanguageEnvironment defaultSystemConverter.
converter ifNil: [^ self].
[readStream atEnd] whileFalse: [
converter nextPut: readStream next toStream: writeStream
].
converter emitSequenceToResetStateIfNeededOn: writeStream.
^ writeStream contents.
!
----- Method: String>>convertToWithConverter: (in category 'converting') -----
convertToWithConverter: converter
| readStream writeStream |
readStream _ self readStream.
writeStream _ String new writeStream.
converter ifNil: [^ self].
[readStream atEnd] whileFalse: [
converter nextPut: readStream next toStream: writeStream
].
converter emitSequenceToResetStateIfNeededOn: writeStream.
^ writeStream contents.
!
----- Method: String>>copy (in category 'copying') -----
copy
^ self clone.
!
----- Method: String>>copyReplaceTokens:with: (in category 'copying') -----
copyReplaceTokens: oldSubstring with: newSubstring
"Replace all occurrences of oldSubstring that are surrounded
by non-alphanumeric characters"
^ self copyReplaceAll: oldSubstring with: newSubstring asTokens: true
"'File asFile Files File''s File' copyReplaceTokens: 'File' with: 'Snick'"!
----- Method: String>>correctAgainst: (in category 'converting') -----
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:"
| results |
results _ self correctAgainst: wordList continuedFrom: nil.
results _ self correctAgainst: nil continuedFrom: results.
^ results!
----- Method: String>>correctAgainst:continuedFrom: (in category 'converting') -----
correctAgainst: wordList continuedFrom: oldCollection
"Like correctAgainst:. Use when you want to correct against several lists, give nil as the first oldCollection, and nil as the last wordList."
^ wordList isNil
ifTrue: [ self correctAgainstEnumerator: nil
continuedFrom: oldCollection ]
ifFalse: [ self correctAgainstEnumerator: [ :action | wordList do: action without: nil]
continuedFrom: oldCollection ]!
----- Method: String>>correctAgainstDictionary:continuedFrom: (in category 'converting') -----
correctAgainstDictionary: wordDict continuedFrom: oldCollection
"Like correctAgainst:continuedFrom:. Use when you want to correct against a dictionary."
^ wordDict isNil
ifTrue: [ self correctAgainstEnumerator: nil
continuedFrom: oldCollection ]
ifFalse: [ self correctAgainstEnumerator: [ :action | wordDict keysDo: action ]
continuedFrom: oldCollection ]!
----- Method: String>>correctAgainstEnumerator:continuedFrom: (in category 'private') -----
correctAgainstEnumerator: wordBlock continuedFrom: oldCollection
"The guts of correction, instead of a wordList, there is a block that should take another block and enumerate over some list with it."
| choices scoreMin results score maxChoices |
scoreMin _ self size // 2 min: 3.
maxChoices _ 10.
oldCollection isNil
ifTrue: [ choices _ SortedCollection sortBlock: [ :x :y | x value > y value ] ]
ifFalse: [ choices _ oldCollection ].
wordBlock isNil
ifTrue:
[ results _ OrderedCollection new.
1 to: (maxChoices min: choices size) do: [ :i | results add: (choices at: i) key ] ]
ifFalse:
[ wordBlock value: [ :word |
(score _ self alike: word) >= scoreMin ifTrue:
[ choices add: (Association key: word value: score).
(choices size >= maxChoices) ifTrue: [ scoreMin _ (choices at: maxChoices) value] ] ].
results _ choices ].
^ results!
----- Method: String>>crc16 (in category 'comparing') -----
crc16
"Compute a 16 bit cyclic redundancy check."
| crc |
crc := 0.
1 to: self byteSize do: [:i |
crc := (crc bitShift: -8) bitXor: (
#( 16r0000 16rC0C1 16rC181 16r0140 16rC301 16r03C0 16r0280 16rC241
16rC601 16r06C0 16r0780 16rC741 16r0500 16rC5C1 16rC481 16r0440
16rCC01 16r0CC0 16r0D80 16rCD41 16r0F00 16rCFC1 16rCE81 16r0E40
16r0A00 16rCAC1 16rCB81 16r0B40 16rC901 16r09C0 16r0880 16rC841
16rD801 16r18C0 16r1980 16rD941 16r1B00 16rDBC1 16rDA81 16r1A40
16r1E00 16rDEC1 16rDF81 16r1F40 16rDD01 16r1DC0 16r1C80 16rDC41
16r1400 16rD4C1 16rD581 16r1540 16rD701 16r17C0 16r1680 16rD641
16rD201 16r12C0 16r1380 16rD341 16r1100 16rD1C1 16rD081 16r1040
16rF001 16r30C0 16r3180 16rF141 16r3300 16rF3C1 16rF281 16r3240
16r3600 16rF6C1 16rF781 16r3740 16rF501 16r35C0 16r3480 16rF441
16r3C00 16rFCC1 16rFD81 16r3D40 16rFF01 16r3FC0 16r3E80 16rFE41
16rFA01 16r3AC0 16r3B80 16rFB41 16r3900 16rF9C1 16rF881 16r3840
16r2800 16rE8C1 16rE981 16r2940 16rEB01 16r2BC0 16r2A80 16rEA41
16rEE01 16r2EC0 16r2F80 16rEF41 16r2D00 16rEDC1 16rEC81 16r2C40
16rE401 16r24C0 16r2580 16rE541 16r2700 16rE7C1 16rE681 16r2640
16r2200 16rE2C1 16rE381 16r2340 16rE101 16r21C0 16r2080 16rE041
16rA001 16r60C0 16r6180 16rA141 16r6300 16rA3C1 16rA281 16r6240
16r6600 16rA6C1 16rA781 16r6740 16rA501 16r65C0 16r6480 16rA441
16r6C00 16rACC1 16rAD81 16r6D40 16rAF01 16r6FC0 16r6E80 16rAE41
16rAA01 16r6AC0 16r6B80 16rAB41 16r6900 16rA9C1 16rA881 16r6840
16r7800 16rB8C1 16rB981 16r7940 16rBB01 16r7BC0 16r7A80 16rBA41
16rBE01 16r7EC0 16r7F80 16rBF41 16r7D00 16rBDC1 16rBC81 16r7C40
16rB401 16r74C0 16r7580 16rB541 16r7700 16rB7C1 16rB681 16r7640
16r7200 16rB2C1 16rB381 16r7340 16rB101 16r71C0 16r7080 16rB041
16r5000 16r90C1 16r9181 16r5140 16r9301 16r53C0 16r5280 16r9241
16r9601 16r56C0 16r5780 16r9741 16r5500 16r95C1 16r9481 16r5440
16r9C01 16r5CC0 16r5D80 16r9D41 16r5F00 16r9FC1 16r9E81 16r5E40
16r5A00 16r9AC1 16r9B81 16r5B40 16r9901 16r59C0 16r5880 16r9841
16r8801 16r48C0 16r4980 16r8941 16r4B00 16r8BC1 16r8A81 16r4A40
16r4E00 16r8EC1 16r8F81 16r4F40 16r8D01 16r4DC0 16r4C80 16r8C41
16r4400 16r84C1 16r8581 16r4540 16r8701 16r47C0 16r4680 16r8641
16r8201 16r42C0 16r4380 16r8341 16r4100 16r81C1 16r8081 16r4040)
at: ((crc bitXor: (self byteAt: i)) bitAnd: 16rFF) + 1) ].
^crc!
----- Method: String>>decodeMimeHeader (in category 'internet') -----
decodeMimeHeader
"See RFC 2047, MIME Part Three: Message Header Extension for Non-ASCII
Text. Text containing non-ASCII characters is encoded by the sequence
=?character-set?encoding?encoded-text?=
Encoding is Q (quoted printable) or B (Base64), handled by
Base64MimeConverter / RFC2047MimeConverter.
Thanks to Yokokawa-san, it works in m17n package. Try the following:
'=?ISO-2022-JP?B?U1dJS0lQT1AvGyRCPUJDKyVpJXMlQRsoQi8=?= =?ISO-2022-JP?B?GyRCJVElRiUjJSobKEIoUGF0aW8p?=' decodeMimeHeader.
"
| input output temp charset decoder encodedStream encoding pos |
input _ ReadStream on: self.
output _ WriteStream on: String new.
[output
nextPutAll: (input upTo: $=).
"ASCII Text"
input atEnd]
whileFalse: [(temp _ input next) = $?
ifTrue: [charset _ input upTo: $?.
encoding _ (input upTo: $?) asUppercase.
temp _ input upTo: $?.
input next.
"Skip final ="
(charset isNil or: [charset size = 0]) ifTrue: [charset _ 'LATIN-1'].
encodedStream _ MultiByteBinaryOrTextStream on: String new encoding: charset.
decoder _ encoding = 'B'
ifTrue: [Base64MimeConverter new]
ifFalse: [RFC2047MimeConverter new].
decoder
mimeStream: (ReadStream on: temp);
dataStream: encodedStream;
mimeDecode.
output nextPutAll: encodedStream reset contents.
pos _ input position.
input skipSeparators.
"Delete spaces if followed by ="
input peek = $=
ifFalse: [input position: pos]]
ifFalse: [output nextPut: $=;
nextPut: temp]].
^ output contents!
----- Method: String>>decodeQuotedPrintable (in category 'internet') -----
decodeQuotedPrintable
"Assume receiver is in MIME 'quoted-printable' encoding, and decode it."
^QuotedPrintableMimeConverter mimeDecode: self as: self class!
----- Method: String>>deepCopy (in category 'copying') -----
deepCopy
"DeepCopy would otherwise mean make a copy of the character; since
characters are unique, just return a shallowCopy."
^self shallowCopy!
----- Method: String>>displayAt: (in category 'displaying') -----
displayAt: aPoint
"Display the receiver as a DisplayText at aPoint on the display screen."
self displayOn: Display at: aPoint!
----- Method: String>>displayOn: (in category 'displaying') -----
displayOn: aDisplayMedium
"Display the receiver on the given DisplayMedium. 5/16/96 sw"
self displayOn: aDisplayMedium at: 0 @ 0!
----- Method: String>>displayOn:at: (in category 'displaying') -----
displayOn: aDisplayMedium at: aPoint
"Show a representation of the receiver as a DisplayText at location aPoint on aDisplayMedium, using black-colored text."
self displayOn: aDisplayMedium at: aPoint textColor: Color black!
----- Method: String>>displayOn:at:textColor: (in category 'displaying') -----
displayOn: aDisplayMedium at: aPoint textColor: aColor
"Show a representation of the receiver as a DisplayText at location aPoint on aDisplayMedium, rendering the text in the designated color"
(self asDisplayText foregroundColor: (aColor ifNil: [Color black]) backgroundColor: Color white)
displayOn: aDisplayMedium at: aPoint!
----- Method: String>>displayProgressAt:from:to:during: (in category 'displaying') -----
displayProgressAt: aPoint from: minVal to: maxVal during: workBlock
"Display this string as a caption over a progress bar while workBlock is evaluated.
EXAMPLE (Select next 6 lines and Do It)
'Now here''s some Real Progress'
displayProgressAt: Sensor cursorPoint
from: 0 to: 10
during: [:bar |
1 to: 10 do: [:x | bar value: x.
(Delay forMilliseconds: 500) wait]].
HOW IT WORKS (Try this in any other language :-)
Since your code (the last 2 lines in the above example) is in a block,
this method gets control to display its heading before, and clean up
the screen after, its execution.
The key, though, is that the block is supplied with an argument,
named 'bar' in the example, which will update the bar image every
it is sent the message value: x, where x is in the from:to: range.
"
^ProgressInitiationException
display: self
at: aPoint
from: minVal
to: maxVal
during: workBlock!
----- Method: String>>do:toFieldNumber: (in category 'accessing') -----
do: aBlock toFieldNumber: aNumber
"Considering the receiver as a holder of tab-delimited fields, evaluate aBlock on behalf of a field in this string"
| start end index |
start _ 1.
index _ 1.
[start <= self size] whileTrue:
[end _ self indexOf: Character tab startingAt: start ifAbsent: [self size + 1].
end _ end - 1.
aNumber = index ifTrue:
[aBlock value: (self copyFrom: start to: end).
^ self].
index _ index + 1.
start _ end + 2]
"
1 to: 6 do:
[:aNumber |
'fred charlie elmo wimpy friml' do:
[:aField | Transcript cr; show: aField] toFieldNumber: aNumber]
"!
----- Method: String>>encodeDoublingQuoteOn: (in category 'printing') -----
encodeDoublingQuoteOn: aStream
"Print inside string quotes, doubling inbedded quotes."
| x |
aStream print: $'.
1 to: self size do:
[:i |
aStream print: (x _ self at: i).
x = $' ifTrue: [aStream print: x]].
aStream print: $'!
----- Method: String>>encodeForHTTP (in category 'converting') -----
encodeForHTTP
"change dangerous characters to their %XX form, for use in HTTP transactions"
^ self encodeForHTTPWithTextEncoding: 'utf-8' conditionBlock: [:c | c isSafeForHTTP].
!
----- Method: String>>encodeForHTTPWithTextEncoding: (in category 'converting') -----
encodeForHTTPWithTextEncoding: encodingName
^ self encodeForHTTPWithTextEncoding: encodingName conditionBlock: [:c | c isSafeForHTTP].
!
----- Method: String>>encodeForHTTPWithTextEncoding:conditionBlock: (in category 'converting') -----
encodeForHTTPWithTextEncoding: encodingName conditionBlock: conditionBlock
"change dangerous characters to their %XX form, for use in HTTP transactions"
| httpSafeStream encodedStream cont |
httpSafeStream _ WriteStream on: (String new).
encodedStream _ MultiByteBinaryOrTextStream on: (String new: 6).
encodedStream converter: (TextConverter newForEncoding: encodingName).
self do: [:c |
(conditionBlock value: c)
ifTrue: [httpSafeStream nextPut: (Character value: c charCode)]
ifFalse: [
encodedStream text; reset.
encodedStream nextPut: c.
encodedStream position: 0.
encodedStream binary.
cont _ encodedStream contents.
cont do: [:byte |
httpSafeStream nextPut: $%.
httpSafeStream nextPut: (byte // 16) asHexDigit.
httpSafeStream nextPut: (byte \\ 16) asHexDigit.
].
].
].
^ httpSafeStream contents.
!
----- Method: String>>endsWith: (in category 'comparing') -----
endsWith: suffix
"Answer whether the tail end of the receiver is the same as suffix.
The comparison is case-sensitive."
| extra |
(extra _ self size - suffix size) < 0 ifTrue: [^ false].
^ (self findSubstring: suffix in: self startingAt: extra + 1
matchTable: CaseSensitiveOrder) > 0
"
'Elvis' endsWith: 'vis'
"!
----- Method: String>>endsWithAColon (in category 'system primitives') -----
endsWithAColon
"Answer whether the final character of the receiver is a colon"
^ self size > 0 and: [self last == $:]
"
#fred: endsWithAColon
'fred' endsWithAColon
"!
----- Method: String>>endsWithAnyOf: (in category 'comparing') -----
endsWithAnyOf: aCollection
aCollection do:[:suffix|
(self endsWith: suffix) ifTrue:[^true].
].
^false!
----- Method: String>>endsWithDigit (in category 'accessing') -----
endsWithDigit
"Answer whether the receiver's final character represents a digit. 3/11/96 sw"
^ self size > 0 and: [self last isDigit]!
----- Method: String>>evaluateExpression:parameters: (in category 'private') -----
evaluateExpression: aString parameters: aCollection
"private - evaluate the expression aString with
aCollection as the parameters and answer the
evaluation result as an string"
| index |
index := ('0' , aString) asNumber.
index isZero
ifTrue: [^ '[invalid subscript: {1}]' format: {aString}].
index > aCollection size
ifTrue: [^ '[subscript is out of bounds: {1}]' format: {aString}].
^ (aCollection at: index) asString!
----- Method: String>>findAnySubStr:startingAt: (in category 'accessing') -----
findAnySubStr: delimiters startingAt: start
"Answer the index of the character within the receiver, starting at start, that begins a substring matching one of the delimiters. delimiters is an Array of Strings (Characters are permitted also). If the receiver does not contain any of the delimiters, answer size + 1."
| min ind |
min _ self size + 1.
delimiters do: [:delim | "May be a char, a string of length 1, or a substring"
delim isCharacter
ifTrue: [ind _ self indexOfSubCollection: (String with: delim)
startingAt: start ifAbsent: [min]]
ifFalse: [ind _ self indexOfSubCollection: delim
startingAt: start ifAbsent: [min]].
min _ min min: ind].
^ min!
----- Method: String>>findBetweenSubStrs: (in category 'accessing') -----
findBetweenSubStrs: delimiters
"Answer the collection of String tokens that result from parsing self. Tokens are separated by 'delimiters', which can be a collection of Strings, or a collection of Characters. Several delimiters in a row are considered as just one separation."
| tokens keyStart keyStop |
tokens _ OrderedCollection new.
keyStop _ 1.
[keyStop <= self size] whileTrue:
[keyStart _ self skipAnySubStr: delimiters startingAt: keyStop.
keyStop _ self findAnySubStr: delimiters startingAt: keyStart.
keyStart < keyStop
ifTrue: [tokens add: (self copyFrom: keyStart to: (keyStop - 1))]].
^tokens!
----- Method: String>>findCloseParenthesisFor: (in category 'accessing') -----
findCloseParenthesisFor: startIndex
"assume (self at: startIndex) is $(. Find the matching $), allowing parentheses to nest."
" '(1+(2-3))-3.14159' findCloseParenthesisFor: 1 "
" '(1+(2-3))-3.14159' findCloseParenthesisFor: 4 "
| pos nestLevel |
pos := startIndex+1.
nestLevel := 1.
[ pos <= self size ] whileTrue: [
(self at: pos) = $( ifTrue: [ nestLevel := nestLevel + 1 ].
(self at: pos) = $) ifTrue: [ nestLevel := nestLevel - 1 ].
nestLevel = 0 ifTrue: [ ^pos ].
pos := pos + 1.
].
^self size + 1!
----- Method: String>>findDelimiters:startingAt: (in category 'accessing') -----
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."
start to: self size do: [:i |
delimiters do: [:delim | delim = (self at: i) ifTrue: [^ i]]].
^ self size + 1!
----- Method: String>>findLastOccuranceOfString:startingAt: (in category 'deprecated-3.10') -----
findLastOccuranceOfString: subString startingAt: start
"Answer the index of the last occurance of subString within the receiver, starting at start. If
the receiver does not contain subString, answer 0."
^ self findLastOccurrenceOfString: subString startingAt: start
!
----- Method: String>>findLastOccurrenceOfString:startingAt: (in category 'accessing') -----
findLastOccurrenceOfString: subString startingAt: start
"Answer the index of the last occurrence of subString within the receiver, starting at start. If
the receiver does not contain subString, answer 0. Case-sensitive match used."
| last now |
last _ self findSubstring: subString in: self startingAt: start matchTable: CaseSensitiveOrder.
last = 0 ifTrue: [^ 0].
[last > 0] whileTrue:
[now _ last.
last _ self findSubstring: subString in: self startingAt: last + 1 matchTable: CaseSensitiveOrder].
^ now
"
'ababa' findLastOccurrenceOfString: 'aba' startingAt: 1
'ababababa' findLastOccurrenceOfString: 'aba' startingAt:3
'aaa' findLastOccurrenceOfString: 'aa' startingAt: 1
"
!
----- Method: String>>findSelector (in category 'converting') -----
findSelector
"Dan's code for hunting down selectors with keyword parts; while this doesn't give a true parse, in most cases it does what we want, in where it doesn't, we're none the worse for it."
| sel possibleParens level n |
sel _ self withBlanksTrimmed.
(sel includes: $:) ifTrue:
[sel _ sel copyReplaceAll: ':' with: ': '. "for the style (aa max:bb) with no space"
possibleParens _ sel findTokens: Character separators.
sel _ self class streamContents:
[:s | level _ 0.
possibleParens do:
[:token |
(level = 0 and: [token endsWith: ':'])
ifTrue: [s nextPutAll: token]
ifFalse: [(n _ token occurrencesOf: $( ) > 0 ifTrue: [level _ level + n].
(n _ token occurrencesOf: $[ ) > 0 ifTrue: [level _ level + n].
(n _ token occurrencesOf: $] ) > 0 ifTrue: [level _ level - n].
(n _ token occurrencesOf: $) ) > 0 ifTrue: [level _ level - n]]]]].
sel isEmpty ifTrue: [^ nil].
sel isOctetString ifTrue: [sel _ sel asOctetString].
Symbol hasInterned: sel ifTrue:
[:aSymbol | ^ aSymbol].
^ nil!
----- Method: String>>findString: (in category 'accessing') -----
findString: subString
"Answer the index of subString within the receiver, starting at start. If
the receiver does not contain subString, answer 0."
^self findString: subString startingAt: 1.!
----- Method: String>>findString:startingAt: (in category 'accessing') -----
findString: subString startingAt: start
"Answer the index of subString within the receiver, starting at start. If
the receiver does not contain subString, answer 0."
^ self findSubstring: subString in: self startingAt: start matchTable: CaseSensitiveOrder!
----- Method: String>>findString:startingAt:caseSensitive: (in category 'accessing') -----
findString: key startingAt: start caseSensitive: caseSensitive
"Answer the index in this String at which the substring key first occurs, at or beyond start. The match can be case-sensitive or not. If no match is found, zero will be returned."
caseSensitive
ifTrue: [^ self findSubstring: key in: self startingAt: start matchTable: CaseSensitiveOrder]
ifFalse: [^ self findSubstring: key in: self startingAt: start matchTable: CaseInsensitiveOrder]!
----- Method: String>>findSubstring:in:startingAt:matchTable: (in category 'system primitives') -----
findSubstring: key in: body startingAt: start matchTable: matchTable
"Answer the index in the string body at which the substring key first occurs, at or beyond start. The match is determined using matchTable, which can be used to effect, eg, case-insensitive matches. If no match is found, zero will be returned."
| index c1 c2 c1Index c2Index |
matchTable == nil ifTrue: [
key size = 0 ifTrue: [^ 0].
start to: body size - key size + 1 do:
[:startIndex |
index _ 1.
[(body at: startIndex+index-1)
= (key at: index)]
whileTrue:
[index = key size ifTrue: [^ startIndex].
index _ index+1]].
^ 0
].
key size = 0 ifTrue: [^ 0].
start to: body size - key size + 1 do:
[:startIndex |
index _ 1.
[c1 _ body at: startIndex+index-1.
c2 _ key at: index.
c1Index _ c1 asciiValue + 1.
c2Index _ c2 asciiValue + 1.
((c1 leadingChar = 0) ifTrue: [
c1Index > matchTable size ifTrue: [c1Index] ifFalse: [matchTable at: c1Index]]
ifFalse: [c1Index])
= ((c2 leadingChar = 0) ifTrue: [
c2Index > matchTable size ifTrue: [c2Index] ifFalse: [matchTable at: c2Index]]
ifFalse: [c2Index])]
whileTrue:
[index = key size ifTrue: [^ startIndex].
index _ index+1]].
^ 0
!
----- Method: String>>findTokens: (in category 'accessing') -----
findTokens: delimiters
"Answer the collection of tokens that result from parsing self. Return strings between the delimiters. Any character in the Collection delimiters marks a border. Several delimiters in a row are considered as just one separation. Also, allow delimiters to be a single character."
| tokens keyStart keyStop separators |
tokens _ OrderedCollection new.
separators _ delimiters isCharacter
ifTrue: [Array with: delimiters]
ifFalse: [delimiters].
keyStop _ 1.
[keyStop <= self size] whileTrue:
[keyStart _ self skipDelimiters: separators startingAt: keyStop.
keyStop _ self findDelimiters: separators startingAt: keyStart.
keyStart < keyStop
ifTrue: [tokens add: (self copyFrom: keyStart to: (keyStop - 1))]].
^tokens!
----- Method: String>>findTokens:includes: (in category 'accessing') -----
findTokens: delimiters includes: subString
"Divide self into pieces using delimiters. Return the piece that includes subString anywhere in it. Is case sensitive (say asLowercase to everything beforehand to make insensitive)."
^ (self findTokens: delimiters)
detect: [:str | (str includesSubString: subString)]
ifNone: [nil]!
----- Method: String>>findTokens:keep: (in category 'accessing') -----
findTokens: delimiters keep: keepers
"Answer the collection of tokens that result from parsing self. The tokens are seperated by delimiters, any of a string of characters. If a delimiter is also in keepers, make a token for it. (Very useful for carriage return. A sole return ends a line, but is also saved as a token so you can see where the line breaks were.)"
| tokens keyStart keyStop |
tokens _ OrderedCollection new.
keyStop _ 1.
[keyStop <= self size] whileTrue:
[keyStart _ self skipDelimiters: delimiters startingAt: keyStop.
keyStop to: keyStart-1 do: [:ii |
(keepers includes: (self at: ii)) ifTrue: [
tokens add: (self copyFrom: ii to: ii)]]. "Make this keeper be a token"
keyStop _ self findDelimiters: delimiters startingAt: keyStart.
keyStart < keyStop
ifTrue: [tokens add: (self copyFrom: keyStart to: (keyStop - 1))]].
^tokens!
----- Method: String>>findWordStart:startingAt: (in category 'accessing') -----
findWordStart: key startingAt: start
| ind |
"HyperCard style searching. Answer the index in self of the substring key, when that key is preceeded by a separator character. Must occur at or beyond start. The match is case-insensitive. If no match is found, zero will be returned."
ind _ start.
[ind _ self findSubstring: key in: self startingAt: ind matchTable: CaseInsensitiveOrder.
ind = 0 ifTrue: [^ 0]. "not found"
ind = 1 ifTrue: [^ 1]. "First char is the start of a word"
(self at: ind-1) isSeparator] whileFalse: [ind _ ind + 1].
^ ind "is a word start"!
----- Method: String>>format: (in category 'formatting') -----
format: aCollection
"format the receiver with aCollection
simplest example:
'foo {1} bar' format: {Date today}.
complete example:
'\{ \} \\ foo {1} bar {2}' format: {12. 'string'}.
"
| result stream |
result := String new writeStream.
stream := self readStream.
[stream atEnd]
whileFalse: [| currentChar |
currentChar := stream next.
currentChar == ${
ifTrue: [| expression |
expression := self getEnclosedExpressionFrom: stream.
result
nextPutAll: (self evaluateExpression: expression parameters: aCollection)]
ifFalse: [
currentChar == $\
ifTrue: [stream atEnd
ifFalse: [result nextPut: stream next]]
ifFalse: [result nextPut: currentChar]]].
^ result contents!
----- Method: String>>fromCamelCase (in category 'converting') -----
fromCamelCase
"convert 'anExampleString' to 'an example string'"
| upper nextWord start |
upper := ($A to: $Z) asCharacterSet.
nextWord := self indexOfAnyOf: upper.
nextWord = 0 ifTrue: [^self].
start := 1.
^String streamContents: [:strm |
[
strm nextPutAll: (self copyFrom: start to: nextWord-1).
strm space; nextPut: (self at: nextWord) asLowercase.
start := nextWord+1.
nextWord := self indexOfAnyOf: upper startingAt: start.
nextWord = 0
] whileFalse.
strm nextPutAll: (self copyFrom: start to: self size).
].!
----- Method: String>>getEnclosedExpressionFrom: (in category 'private') -----
getEnclosedExpressionFrom: aStream
"private - get the expression enclosed between '{' and
'}' and remove all the characters from the stream"
| result currentChar |
result := String new writeStream.
[aStream atEnd
or: [(currentChar := aStream next) == $}]]
whileFalse: [result nextPut: currentChar].
^ result contents withBlanksTrimmed!
----- Method: String>>getInteger32: (in category 'encoding') -----
getInteger32: location
| integer |
<primitive: 'getInteger' module: 'IntegerPokerPlugin'>
"^IntegerPokerPlugin doPrimitive: #getInteger"
"the following is about 7x faster than interpreting the plugin if not compiled"
integer :=
((self at: location) asInteger bitShift: 24) +
((self at: location+1) asInteger bitShift: 16) +
((self at: location+2) asInteger bitShift: 8) +
(self at: location+3) asInteger.
integer > 1073741824 ifTrue: [^1073741824 - integer ].
^integer
!
----- Method: String>>hash (in category 'comparing') -----
hash
"#hash is implemented, because #= is implemented"
"ar 4/10/2005: I had to change this to use ByteString hash as initial
hash in order to avoid having to rehash everything and yet compute
the same hash for ByteString and WideString."
^ self class stringHash: self initialHash: ByteString hash!
----- Method: String>>hashMappedBy: (in category 'comparing') -----
hashMappedBy: map
"My hash is independent of my oop."
^self hash!
----- Method: String>>hashWithInitialHash: (in category 'comparing') -----
hashWithInitialHash: initialHash
^ self class stringHash: self initialHash: initialHash!
----- Method: String>>howManyMatch: (in category 'comparing') -----
howManyMatch: string
"Count the number of characters that match up in self and aString."
| count shorterLength |
count _ 0 .
shorterLength _ ((self size ) min: (string size ) ) .
(1 to: shorterLength do: [:index |
(((self at: index ) = (string at: index ) ) ifTrue: [count _ (count + 1 ) .
] ).
] ).
^ count
!
----- Method: String>>includesSubString: (in category 'accessing') -----
includesSubString: subString
^ (self findString: subString startingAt: 1) > 0!
----- Method: String>>includesSubstring:caseSensitive: (in category 'accessing') -----
includesSubstring: aString caseSensitive: caseSensitive
^ (self findString: aString startingAt: 1 caseSensitive: caseSensitive) > 0!
----- Method: String>>includesUnifiedCharacter (in category 'testing') -----
includesUnifiedCharacter
^false!
----- Method: String>>indentationIfBlank: (in category 'paragraph support') -----
indentationIfBlank: aBlock
"Answer the number of leading tabs in the receiver. If there are
no visible characters, pass the number of tabs to aBlock and return its value."
| reader leadingTabs lastSeparator cr tab ch |
cr _ Character cr.
tab _ Character tab.
reader _ ReadStream on: self.
leadingTabs _ 0.
[reader atEnd not and: [(ch _ reader next) = tab]]
whileTrue: [leadingTabs _ leadingTabs + 1].
lastSeparator _ leadingTabs + 1.
[reader atEnd not and: [ch isSeparator and: [ch ~= cr]]]
whileTrue: [lastSeparator _ lastSeparator + 1. ch _ reader next].
lastSeparator = self size | (ch = cr)
ifTrue: [^aBlock value: leadingTabs].
^ leadingTabs.
!
----- Method: String>>indexOf: (in category 'accessing') -----
indexOf: aCharacter
aCharacter isCharacter ifFalse: [^ 0].
^ self class
indexOfAscii: aCharacter asciiValue
inString: self
startingAt: 1.
!
----- Method: String>>indexOf:startingAt: (in category 'accessing') -----
indexOf: aCharacter startingAt: start
(aCharacter isCharacter) ifFalse: [^ 0].
^ self class indexOfAscii: aCharacter asciiValue inString: self startingAt: start!
----- Method: String>>indexOf:startingAt:ifAbsent: (in category 'accessing') -----
indexOf: aCharacter startingAt: start ifAbsent: aBlock
| ans |
(aCharacter isCharacter) ifFalse: [ ^ aBlock value ].
ans _ self class indexOfAscii: aCharacter asciiValue inString: self startingAt: start.
ans = 0
ifTrue: [ ^ aBlock value ]
ifFalse: [ ^ ans ]!
----- Method: String>>indexOfAnyOf: (in category 'accessing') -----
indexOfAnyOf: aCharacterSet
"returns the index of the first character in the given set. Returns 0 if none are found"
^self indexOfAnyOf: aCharacterSet startingAt: 1!
----- Method: String>>indexOfAnyOf:ifAbsent: (in category 'accessing') -----
indexOfAnyOf: aCharacterSet ifAbsent: aBlock
"returns the index of the first character in the given set. Returns the evaluation of aBlock if none are found"
^self indexOfAnyOf: aCharacterSet startingAt: 1 ifAbsent: aBlock!
----- Method: String>>indexOfAnyOf:startingAt: (in category 'accessing') -----
indexOfAnyOf: aCharacterSet startingAt: start
"returns the index of the first character in the given set, starting from start. Returns 0 if none are found"
^self indexOfAnyOf: aCharacterSet startingAt: start ifAbsent: [ 0 ]!
----- Method: String>>indexOfAnyOf:startingAt:ifAbsent: (in category 'accessing') -----
indexOfAnyOf: aCharacterSet startingAt: start ifAbsent: aBlock
"returns the index of the first character in the given set, starting from start"
| ans |
ans _ self class findFirstInString: self inSet: aCharacterSet byteArrayMap startingAt: start.
ans = 0
ifTrue: [ ^aBlock value ]
ifFalse: [ ^ans ]!
----- Method: String>>indexOfSubCollection: (in category 'accessing') -----
indexOfSubCollection: sub
#Collectn.
"Added 2000/04/08 For ANSI <sequenceReadableCollection> protocol."
^ self
indexOfSubCollection: sub
startingAt: 1
ifAbsent: [0]!
----- Method: String>>indexOfSubCollection:startingAt:ifAbsent: (in category 'accessing') -----
indexOfSubCollection: sub startingAt: start ifAbsent: exceptionBlock
| index |
index _ self findSubstring: sub in: self startingAt: start matchTable: CaseSensitiveOrder.
index = 0 ifTrue: [^ exceptionBlock value].
^ index!
----- Method: String>>initialIntegerOrNil (in category 'converting') -----
initialIntegerOrNil
"Answer the integer represented by the leading digits of the receiver, or nil if the receiver does not begin with a digit"
| firstNonDigit |
(self size == 0 or: [self first isDigit not]) ifTrue: [^ nil].
firstNonDigit _ (self findFirst: [:m | m isDigit not]).
firstNonDigit = 0 ifTrue: [firstNonDigit _ self size + 1].
^ (self copyFrom: 1 to: (firstNonDigit - 1)) asNumber
"
'234Whoopie' initialIntegerOrNil
'wimpy' initialIntegerOrNil
'234' initialIntegerOrNil
'2N' initialIntegerOrNil
'2' initialIntegerOrNil
' 89Ten ' initialIntegerOrNil
'78 92' initialIntegerOrNil
"
!
----- Method: String>>isAllDigits (in category 'testing') -----
isAllDigits
"whether the receiver is composed entirely of digits"
self do: [:c | c isDigit ifFalse: [^ false]].
^ true!
----- Method: String>>isAllSeparators (in category 'testing') -----
isAllSeparators
"whether the receiver is composed entirely of separators"
self do: [ :c | c isSeparator ifFalse: [ ^false ] ].
^true!
----- Method: String>>isAsciiString (in category 'testing') -----
isAsciiString
| c |
c _ self detect: [:each | each asciiValue > 127] ifNone: [nil].
^ c isNil.
!
----- Method: String>>isByteString (in category 'testing') -----
isByteString
"Answer whether the receiver is a ByteString"
^false!
----- Method: String>>isLiteral (in category 'printing') -----
isLiteral
^true!
----- Method: String>>isOctetString (in category 'testing') -----
isOctetString
"Answer whether the receiver can be represented as a byte string.
This is different from asking whether the receiver *is* a ByteString
(i.e., #isByteString)"
1 to: self size do: [:pos |
(self at: pos) asInteger >= 256 ifTrue: [^ false].
].
^ true.
!
----- Method: String>>isReallyString (in category 'testing') -----
isReallyString
^ true!
----- Method: String>>isString (in category 'testing') -----
isString
^ true!
----- Method: String>>isWideString (in category 'testing') -----
isWideString
"Answer whether the receiver is a WideString"
^false!
----- Method: String>>isoToSqueak (in category 'internet') -----
isoToSqueak
^self "no longer needed"!
----- Method: String>>isoToUtf8 (in category 'internet') -----
isoToUtf8
"Convert ISO 8559-1 to UTF-8"
| s v |
s _ WriteStream on: (String new: self size).
self do: [:c |
v _ c asciiValue.
(v > 128)
ifFalse: [s nextPut: c]
ifTrue: [
s nextPut: (192+(v >> 6)) asCharacter.
s nextPut: (128+(v bitAnd: 63)) asCharacter]].
^s contents.
!
----- Method: String>>keywords (in category 'converting') -----
keywords
"Answer an array of the keywords that compose the receiver."
| kwd char keywords |
keywords _ Array streamContents:
[:kwds | kwd _ WriteStream on: (String new: 16).
1 to: self size do:
[:i |
kwd nextPut: (char _ self at: i).
char = $: ifTrue:
[kwds nextPut: kwd contents.
kwd reset]].
kwd isEmpty ifFalse: [kwds nextPut: kwd contents]].
(keywords size >= 1 and: [(keywords at: 1) = ':']) ifTrue:
["Has an initial keyword, as in #:if:then:else:"
keywords _ keywords allButFirst].
(keywords size >= 2 and: [(keywords at: keywords size - 1) = ':']) ifTrue:
["Has a final keyword, as in #nextPut::andCR"
keywords _ keywords copyReplaceFrom: keywords size - 1
to: keywords size with: {':' , keywords last}].
^ keywords!
----- Method: String>>lastIndexOfPKSignature: (in category 'accessing') -----
lastIndexOfPKSignature: aSignature
"Answer the last index in me where aSignature (4 bytes long) occurs, or 0 if not found"
| a b c d |
a _ aSignature first.
b _ aSignature second.
c _ aSignature third.
d _ aSignature fourth.
(self size - 3) to: 1 by: -1 do: [ :i |
(((self at: i) = a)
and: [ ((self at: i + 1) = b)
and: [ ((self at: i + 2) = c)
and: [ ((self at: i + 3) = d) ]]])
ifTrue: [ ^i ]
].
^0!
----- Method: String>>lastSpacePosition (in category 'testing') -----
lastSpacePosition
"Answer the character position of the final space or other separator character in the receiver, and 0 if none"
self size to: 1 by: -1 do:
[:i | ((self at: i) isSeparator) ifTrue: [^ i]].
^ 0
"
'fred the bear' lastSpacePosition
'ziggie' lastSpacePosition
'elvis ' lastSpacePosition
'wimpy ' lastSpacePosition
'' lastSpacePosition
"!
----- Method: String>>leadingCharRunLengthAt: (in category 'accessing') -----
leadingCharRunLengthAt: index
| leadingChar |
leadingChar _ (self at: index) leadingChar.
index to: self size do: [:i |
(self at: i) leadingChar ~= leadingChar ifTrue: [^ i - index].
].
^ self size - index + 1.
!
----- Method: String>>lineCorrespondingToIndex: (in category 'accessing') -----
lineCorrespondingToIndex: anIndex
"Answer a string containing the line at the given character position. 1/15/96 sw: Inefficient first stab at this"
| cr aChar answer |
cr _ Character cr.
answer _ ''.
1 to: self size do:
[:i |
aChar _ self at: i.
aChar = cr
ifTrue:
[i > anIndex
ifTrue:
[^ answer]
ifFalse:
[answer _ '']]
ifFalse:
[answer _ answer copyWith: aChar]].
^ answer!
----- Method: String>>lineCount (in category 'accessing') -----
lineCount
"Answer the number of lines represented by the receiver, where every cr adds one line. 5/10/96 sw"
| cr count |
cr _ Character cr.
count _ 1 min: self size..
1 to: self size do:
[:i | (self at: i) = cr ifTrue: [count _ count + 1]].
^ count
"
'Fred
the
Bear' lineCount
"!
----- Method: String>>lineNumber: (in category 'accessing') -----
lineNumber: anIndex
"Answer a string containing the characters in the given line number. 5/10/96 sw"
| crString pos finalPos |
crString _ String with: Character cr.
pos _ 0.
1 to: anIndex - 1 do:
[:i | pos _ self findString: crString startingAt: pos + 1.
pos = 0 ifTrue: [^ nil]].
finalPos _ self findString: crString startingAt: pos + 1.
finalPos = 0 ifTrue: [finalPos _ self size + 1].
^ self copyFrom: pos + 1 to: finalPos - 1
"
'Fred
the
Bear' lineNumber: 3
"!
----- Method: String>>linesDo: (in category 'accessing') -----
linesDo: aBlock
"execute aBlock with each line in this string. The terminating CR's are not included in what is passed to aBlock"
| start end |
start _ 1.
[ start <= self size ] whileTrue: [
end _ self indexOf: Character cr startingAt: start ifAbsent: [ self size + 1 ].
end _ end - 1.
aBlock value: (self copyFrom: start to: end).
start _ end + 2. ].!
----- Method: String>>macToSqueak (in category 'internet') -----
macToSqueak
"Convert the receiver from MacRoman to Squeak encoding"
^ self collect: [:each | each macToSqueak]!
----- Method: String>>match: (in category 'comparing') -----
match: text
"Answer whether text matches the pattern in this string.
Matching ignores upper/lower case differences.
Where this string contains #, text may contain any character.
Where this string contains *, text may contain any sequence of characters."
^ self startingAt: 1 match: text startingAt: 1
"
'*' match: 'zort' true
'*baz' match: 'mobaz' true
'*baz' match: 'mobazo' false
'*baz*' match: 'mobazo' true
'*baz*' match: 'mozo' false
'foo*' match: 'foozo' true
'foo*' match: 'bozo' false
'foo*baz' match: 'foo23baz' true
'foo*baz' match: 'foobaz' true
'foo*baz' match: 'foo23bazo' false
'foo' match: 'Foo' true
'foo*baz*zort' match: 'foobazort' false
'foo*baz*zort' match: 'foobazzort' false
'*foo#zort' match: 'afoo3zortthenfoo3zort' true
'*foo*zort' match: 'afoodezortorfoo3zort' true
"!
----- Method: String>>numArgs (in category '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."
| firstChar numColons excess start ix |
self size = 0 ifTrue: [^ -1].
firstChar _ self at: 1.
(firstChar isLetter or: [firstChar = $:]) ifTrue:
["Fast reject if any chars are non-alphanumeric"
(self findSubstring: '~' in: self startingAt: 1 matchTable: Tokenish) > 0 ifTrue: [^ -1].
"Fast colon count"
numColons _ 0. start _ 1.
[(ix _ self findSubstring: ':' in: self startingAt: start matchTable: CaseSensitiveOrder) > 0]
whileTrue:
[numColons _ numColons + 1.
start _ ix + 1].
numColons = 0 ifTrue: [^ 0].
firstChar = $:
ifTrue: [excess _ 2 "Has an initial keyword, as #:if:then:else:"]
ifFalse: [excess _ 0].
self last = $:
ifTrue: [^ numColons - excess]
ifFalse: [^ numColons - excess - 1 "Has a final keywords as #nextPut::andCR"]].
firstChar isSpecial ifTrue:
[self size = 1 ifTrue: [^ 1].
2 to: self size do: [:i | (self at: i) isSpecial ifFalse: [^ -1]].
^ 1].
^ -1.!
----- Method: String>>numericSuffix (in category 'converting') -----
numericSuffix
^ self stemAndNumericSuffix last
"
'abc98' numericSuffix
'98abc' numericSuffix
"!
----- Method: String>>onlyLetters (in category 'converting') -----
onlyLetters
"answer the receiver with only letters"
^ self select:[:each | each isLetter]!
----- Method: String>>openInWorkspaceWithTitle: (in category 'user interface') -----
openInWorkspaceWithTitle: aTitle
"Open up a workspace with the receiver as its contents, with the given title"
(Workspace new contents: self) openLabel: aTitle!
----- Method: String>>padded:to:with: (in category 'copying') -----
padded: leftOrRight to: length with: char
leftOrRight = #left ifTrue:
[^ (String new: (length - self size max: 0) withAll: char) , self].
leftOrRight = #right ifTrue:
[^ self , (String new: (length - self size max: 0) withAll: char)].!
----- Method: String>>passwordFor: (in category 'password compatibility') -----
passwordFor: aServerDir
^ self.
!
----- Method: String>>printOn: (in category 'printing') -----
printOn: aStream
"Print inside string quotes, doubling inbedded quotes."
self storeOn: aStream!
----- Method: String>>putInteger32:at: (in category 'encoding') -----
putInteger32: anInteger at: location
| integer |
<primitive: 'putInteger' module: 'IntegerPokerPlugin'>
"IntegerPokerPlugin doPrimitive: #putInteger"
"the following is close to 20x faster than the above if the primitive is not compiled"
"PUTCOUNTER _ PUTCOUNTER + 1."
integer _ anInteger.
integer < 0 ifTrue: [integer := 1073741824 - integer. ].
self at: location+3 put: (Character value: (integer \\ 256)).
self at: location+2 put: (Character value: (integer bitShift: -8) \\ 256).
self at: location+1 put: (Character value: (integer bitShift: -16) \\ 256).
self at: location put: (Character value: (integer bitShift: -24) \\ 256).
"Smalltalk at: #PUTCOUNTER put: 0"!
----- Method: String>>putOn: (in category 'filter streaming') -----
putOn:aStream
^aStream nextPutAll: self.
!
----- Method: String>>replaceFrom:to:with:startingAt: (in category '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!
----- Method: String>>romanNumber (in category 'converting') -----
romanNumber
| value v1 v2 |
value _ v1 _ v2 _ 0.
self reverseDo:
[:each |
v1 _ #(1 5 10 50 100 500 1000) at: ('IVXLCDM' indexOf: each).
v1 >= v2
ifTrue: [value _ value + v1]
ifFalse: [value _ value - v1].
v2 _ v1].
^ value!
----- Method: String>>sameAs: (in category 'comparing') -----
sameAs: aString
"Answer whether the receiver sorts equal to aString. The
collation sequence is ascii with case differences ignored."
^(self compare: aString caseSensitive: false) = 2!
----- Method: String>>sansPeriodSuffix (in category 'converting') -----
sansPeriodSuffix
"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]!
----- Method: String>>shallowCopy (in category 'copying') -----
shallowCopy
^ self clone.
!
----- Method: String>>skipAnySubStr:startingAt: (in category 'accessing') -----
skipAnySubStr: delimiters startingAt: start
"Answer the index of the last character within the receiver, starting at start, that does NOT match one of the delimiters. delimiters is a Array of substrings (Characters also allowed). If the receiver is all delimiters, answer size + 1."
| any this ind ii |
ii _ start-1.
[(ii _ ii + 1) <= self size] whileTrue: [ "look for char that does not match"
any _ false.
delimiters do: [:delim |
delim isCharacter
ifTrue: [(self at: ii) == delim ifTrue: [any _ true]]
ifFalse: ["a substring"
delim size > (self size - ii + 1) ifFalse: "Here's where the one-off error was."
[ind _ 0.
this _ true.
delim do: [:dd |
dd == (self at: ii+ind) ifFalse: [this _ false].
ind _ ind + 1].
this ifTrue: [ii _ ii + delim size - 1. any _ true]]
ifTrue: [any _ false] "if the delim is too big, it can't match"]].
any ifFalse: [^ ii]].
^ self size + 1!
----- Method: String>>skipDelimiters:startingAt: (in category 'accessing') -----
skipDelimiters: delimiters startingAt: start
"Answer the index of the character within the receiver, starting at start, that does NOT match 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."
start to: self size do: [:i |
delimiters detect: [:delim | delim = (self at: i)]
ifNone: [^ i]].
^ self size + 1!
----- Method: String>>splitInteger (in category 'converting') -----
splitInteger
"Answer an array that is a splitting of self into a string and an integer.
'43Sam' ==> #(43 'Sam'). 'Try90' ==> #('Try' 90)
BUT NOTE: 'Sam' ==> #('Sam' 0), and '90' ==> #('' 90) ie, (<string> <integer>)."
| pos |
(pos _ self findFirst: [:d | d isDigit not]) = 0 ifTrue: [^ Array with: '' with: self asNumber].
self first isDigit ifTrue: [
^ Array with: (self copyFrom: 1 to: pos - 1) asNumber
with: (self copyFrom: pos to: self size)].
(pos _ self findFirst: [:d | d isDigit]) = 0 ifTrue: [^ Array with: self with: 0].
^ Array with: (self copyFrom: 1 to: pos - 1)
with: (self copyFrom: pos to: self size) asNumber!
----- Method: String>>squeakToIso (in category 'internet') -----
squeakToIso
^self "no longer needed"!
----- Method: String>>squeakToMac (in category 'internet') -----
squeakToMac
"Convert the receiver from Squeak to MacRoman encoding"
^ self collect: [:each | each squeakToMac]!
----- Method: String>>squeakToUtf8 (in category 'converting') -----
squeakToUtf8
"Convert the receiver into a UTF8-encoded string"
^self convertToWithConverter: UTF8TextConverter new.!
----- Method: String>>startingAt:match:startingAt: (in category 'comparing') -----
startingAt: keyStart match: text startingAt: textStart
"Answer whether text matches the pattern in this string.
Matching ignores upper/lower case differences.
Where this string contains #, text may contain any character.
Where this string contains *, text may contain any sequence of characters."
| anyMatch matchStart matchEnd i matchStr j ii jj |
i _ keyStart.
j _ textStart.
"Check for any #'s"
[i > self size ifTrue: [^ j > text size "Empty key matches only empty string"].
(self at: i) = $#] whileTrue:
["# consumes one char of key and one char of text"
j > text size ifTrue: [^ false "no more text"].
i _ i+1. j _ j+1].
"Then check for *"
(self at: i) = $*
ifTrue: [i = self size ifTrue:
[^ true "Terminal * matches all"].
"* means next match string can occur anywhere"
anyMatch _ true.
matchStart _ i + 1]
ifFalse: ["Otherwise match string must occur immediately"
anyMatch _ false.
matchStart _ i].
"Now determine the match string"
matchEnd _ self size.
(ii _ self indexOf: $* startingAt: matchStart) > 0 ifTrue:
[ii = 1 ifTrue: [self error: '** not valid -- use * instead'].
matchEnd _ ii-1].
(ii _ self indexOf: $# startingAt: matchStart) > 0 ifTrue:
[ii = 1 ifTrue: [self error: '*# not valid -- use #* instead'].
matchEnd _ matchEnd min: ii-1].
matchStr _ self copyFrom: matchStart to: matchEnd.
"Now look for the match string"
[jj _ text findString: matchStr startingAt: j caseSensitive: false.
anyMatch ifTrue: [jj > 0] ifFalse: [jj = j]]
whileTrue:
["Found matchStr at jj. See if the rest matches..."
(self startingAt: matchEnd+1 match: text startingAt: jj + matchStr size) ifTrue:
[^ true "the rest matches -- success"].
"The rest did not match."
anyMatch ifFalse: [^ false].
"Preceded by * -- try for a later match"
j _ j+1].
^ false "Failed to find the match string"!
----- Method: String>>startsWithDigit (in category 'accessing') -----
startsWithDigit
"Answer whether the receiver's first character represents a digit"
^ self size > 0 and: [self first isDigit]!
----- Method: String>>stemAndNumericSuffix (in category 'converting') -----
stemAndNumericSuffix
"Parse the receiver into a string-valued stem and a numeric-valued suffix. 6/7/96 sw"
| stem suffix position |
stem _ self.
suffix _ 0.
position _ 1.
[stem endsWithDigit and: [stem size > 1]] whileTrue:
[suffix _ stem last digitValue * position + suffix.
position _ position * 10.
stem _ stem copyFrom: 1 to: stem size - 1].
^ Array with: stem with: suffix
"'Fred2305' stemAndNumericSuffix"!
----- Method: String>>storeOn: (in category 'printing') -----
storeOn: aStream
"Print inside string quotes, doubling inbedded quotes."
| x |
aStream nextPut: $'.
1 to: self size do:
[:i |
aStream nextPut: (x _ self at: i).
x = $' ifTrue: [aStream nextPut: x]].
aStream nextPut: $'!
----- Method: String>>stringRepresentation (in category 'printing') -----
stringRepresentation
"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"
^ self !
----- Method: String>>stringhash (in category 'private') -----
stringhash
^ self hash.
!
----- Method: String>>subStrings (in category 'converting') -----
subStrings
"Answer an array of the substrings that compose the receiver."
#Collectn.
"Added 2000/04/08 For ANSI <readableString> protocol."
^ self substrings!
----- Method: String>>subStrings: (in category 'converting') -----
subStrings: separators
"Answer an array containing the substrings in the receiver separated
by the elements of separators."
| char result sourceStream subString |
#Collectn.
"Changed 2000/04/08 For ANSI <readableString> protocol."
(separators isString or:[separators allSatisfy: [:element | element isKindOf: Character]])
ifFalse: [^ self error: 'separators must be Characters.'].
sourceStream := ReadStream on: self.
result := OrderedCollection new.
subString := String new.
[sourceStream atEnd]
whileFalse:
[char := sourceStream next.
(separators includes: char)
ifTrue: [subString notEmpty
ifTrue:
[result add: subString copy.
subString := String new]]
ifFalse: [subString := subString , (String with: char)]].
subString notEmpty ifTrue: [result add: subString copy].
^ result asArray!
----- Method: String>>substrings (in category 'converting') -----
substrings
"Answer an array of the substrings that compose the receiver."
| result end beginning |
result _ WriteStream on: (Array new: 10).
end _ 0.
"find one substring each time through this loop"
[
"find the beginning of the next substring"
beginning _ self indexOfAnyOf: CSNonSeparators startingAt: end+1 ifAbsent: [ nil ].
beginning ~~ nil ]
whileTrue: [
"find the end"
end _ self indexOfAnyOf: CSSeparators startingAt: beginning ifAbsent: [ self size + 1 ].
end _ end - 1.
result nextPut: (self copyFrom: beginning to: end).
].
^result contents!
----- Method: String>>sunitAsSymbol (in category 'Camp Smalltalk') -----
sunitAsSymbol
^self asSymbol!
----- Method: String>>sunitMatch: (in category 'Camp Smalltalk') -----
sunitMatch: aString
^(self match: aString)
and: [aString numArgs = 0]!
----- Method: String>>sunitSubStrings (in category 'Camp Smalltalk') -----
sunitSubStrings
^self substrings!
----- Method: String>>surroundedBySingleQuotes (in category 'converting') -----
surroundedBySingleQuotes
"Answer the receiver with leading and trailing quotes. "
^ $' asString, self, $' asString!
----- Method: String>>tabDelimitedFieldsDo: (in category 'accessing') -----
tabDelimitedFieldsDo: aBlock
"Considering the receiver as a holder of tab-delimited fields, evaluate execute aBlock with each field in this string. The separatilng tabs are not included in what is passed to aBlock"
| start end |
"No senders but was useful enough in earlier work that it's retained for the moment."
start _ 1.
[start <= self size] whileTrue:
[end _ self indexOf: Character tab startingAt: start ifAbsent: [self size + 1].
end _ end - 1.
aBlock value: (self copyFrom: start to: end).
start _ end + 2]
"
'fred charlie elmo 2' tabDelimitedFieldsDo: [:aField | Transcript cr; show: aField]
"!
----- Method: String>>toCamelCase (in category 'converting') -----
toCamelCase
"convert 'an example string' to 'anExampleString'"
(self includes: Character space) ifFalse: [^self].
^String streamContents: [:strm |
| space start |
space := self indexOf: Character space.
strm nextPutAll: (self copyFrom: 1 to: space-1).
[ [start := space+1.
space := self indexOf: Character space startingAt: start.
space = start] whileTrue.
space = 0 ifTrue: [space := self size+1].
start <= self size ifTrue: [
strm nextPut: (self at: start) asUppercase.
strm nextPutAll: (self copyFrom: start+1 to: space-1)].
space < self size
] whileTrue].!
----- Method: String>>translateFrom:to:table: (in category 'converting') -----
translateFrom: start to: stop table: table
"translate the characters in the string by the given table, in place"
self class translate: self from: start to: stop table: table!
----- Method: String>>translateToLowercase (in category 'converting') -----
translateToLowercase
"Translate all characters to lowercase, in place"
self translateWith: LowercasingTable!
----- Method: String>>translateToUppercase (in category 'converting') -----
translateToUppercase
"Translate all characters to lowercase, in place"
self translateWith: UppercasingTable!
----- Method: String>>translateWith: (in category 'converting') -----
translateWith: table
"translate the characters in the string by the given table, in place"
^ self translateFrom: 1 to: self size table: table!
----- Method: String>>truncateTo: (in category 'converting') -----
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]!
----- Method: String>>truncateWithElipsisTo: (in category 'converting') -----
truncateWithElipsisTo: maxLength
"Return myself or a copy suitably shortened but with elipsis added"
^ self size <= maxLength
ifTrue:
[self]
ifFalse:
[(self copyFrom: 1 to: (maxLength - 3)), '...']
"'truncateWithElipsisTo:' truncateWithElipsisTo: 20"!
----- Method: String>>unescapePercents (in category 'converting') -----
unescapePercents
"decode %xx form. This is the opposite of #encodeForHTTP"
^ self unescapePercentsWithTextEncoding: 'utf-8'.!
----- Method: String>>unescapePercentsWithTextEncoding: (in category 'converting') -----
unescapePercentsWithTextEncoding: encodingName
"decode string including %XX form"
| ans c asciiVal pos oldPos specialChars encodedStream converter |
encodedStream _ ReadWriteStream on: String new.
converter _ TextConverter newForEncoding: encodingName.
ans _ WriteStream on: String new.
oldPos _ 1.
specialChars _ '+%' asCharacterSet.
[pos _ self indexOfAnyOf: specialChars startingAt: oldPos. pos > 0]
whileTrue: [
ans nextPutAll: (self copyFrom: oldPos to: pos - 1).
c _ self at: pos.
(c = $% and: [pos + 2 <= self size])
ifTrue: [
encodedStream reset.
[c = $% ] whileTrue: [
asciiVal _ (self at: pos+1) asUppercase digitValue * 16 +
(self at: pos+2) asUppercase digitValue.
asciiVal > 255 ifTrue: [^self]. "not really an escaped string".
encodedStream nextPut: (Character value: asciiVal).
pos _ pos + 3.
(pos <= self size)
ifTrue: [c _ self at: pos]
ifFalse: [c _ nil].
].
encodedStream position: 0.
[(c _ converter nextFromStream: encodedStream) notNil ] whileTrue: [
ans nextPut: c].
oldPos _ pos.
]
ifFalse: [ans nextPut: c.
oldPos _ pos + 1
].
].
(oldPos <= self size) ifTrue: [
ans nextPutAll: (self copyFrom: oldPos to: self size) ].
^ ans contents!
----- Method: String>>unparenthetically (in category 'converting') -----
unparenthetically
"If the receiver starts with (..( and ends with matching )..), strip them"
| curr |
curr _ self.
[((curr first = $() and: [curr last = $)])] whileTrue:
[curr _ curr copyFrom: 2 to: (curr size - 1)].
^ curr
"
'((fred the bear))' unparenthetically
"
!
----- Method: String>>unzipped (in category 'converting') -----
unzipped
| magic1 magic2 |
magic1 _ (self at: 1) asInteger.
magic2 _ (self at: 2) asInteger.
(magic1 = 16r1F and:[magic2 = 16r8B]) ifFalse:[^self].
^(GZipReadStream on: self) upToEnd!
----- Method: String>>utf8ToIso (in category 'internet') -----
utf8ToIso
"Only UTF-8 characters that maps to 8-bit ISO-8559-1 values are converted. Others raises an error"
| s i c v c2 v2 |
s _ WriteStream on: (String new: self size).
i _ 1.
[i <= self size] whileTrue: [
c _ self at: i. i_i+1.
v _ c asciiValue.
(v > 128)
ifFalse: [ s nextPut: c ]
ifTrue: [((v bitAnd: 252) == 192)
ifFalse: [self error: 'illegal UTF-8 ISO character']
ifTrue: [
(i > self size) ifTrue: [ self error: 'illegal end-of-string, expected 2nd byte of UTF-8'].
c2 _ self at: i. i_i+1.
v2 _ c2 asciiValue.
((v2 bitAnd: 192) = 128) ifFalse: [self error: 'illegal 2nd UTF-8 char'].
s nextPut: ((v2 bitAnd: 63) bitOr: ((v << 6) bitAnd: 192)) asCharacter]]].
^s contents.
!
----- Method: String>>utf8ToSqueak (in category 'converting') -----
utf8ToSqueak
"Convert the receiver from a UTF8-encoded string"
^self convertFromWithConverter: UTF8TextConverter new.!
----- Method: String>>withBlanksCondensed (in category 'converting') -----
withBlanksCondensed
"Return a copy of the receiver with leading/trailing blanks removed
and consecutive white spaces condensed."
| trimmed lastBlank |
trimmed _ self withBlanksTrimmed.
^String streamContents: [:stream |
lastBlank _ false.
trimmed do: [:c | (c isSeparator and: [lastBlank]) ifFalse: [stream nextPut: c].
lastBlank _ c isSeparator]].
" ' abc d ' withBlanksCondensed"
!
----- Method: String>>withBlanksTrimmed (in category 'converting') -----
withBlanksTrimmed
"Return a copy of the receiver from which leading and trailing blanks have been trimmed."
| first result |
first _ self findFirst: [:c | c isSeparator not].
first = 0 ifTrue: [^ '']. "no non-separator character"
result _ self
copyFrom: first
to: (self findLast: [:c | c isSeparator not]).
result isOctetString ifTrue: [^ result asOctetString] ifFalse: [^ result].
" ' abc d ' withBlanksTrimmed"
!
----- Method: String>>withCRs (in category 'formatting') -----
withCRs
"Return a copy of the receiver in which backslash (\) characters have been replaced with carriage returns."
^ self collect: [ :c | c = $\ ifTrue: [ Character cr ] ifFalse: [ c ]].!
----- Method: String>>withFirstCharacterDownshifted (in category 'converting') -----
withFirstCharacterDownshifted
"Return a copy with the first letter downShifted"
| answer |
self ifEmpty: [^ self copy].
answer _ self copy.
answer at: 1 put: (answer at: 1) asLowercase.
^ answer. !
----- Method: String>>withInternetLineEndings (in category 'internet') -----
withInternetLineEndings
"change line endings from CR's to CRLF's. This is probably in
prepration for sending a string over the Internet"
| cr lf |
cr _ Character cr.
lf _ Character linefeed.
^self class streamContents: [ :stream |
self do: [ :c |
stream nextPut: c.
c = cr ifTrue:[ stream nextPut: lf ]. ] ].!
----- Method: String>>withNoLineLongerThan: (in category 'converting') -----
withNoLineLongerThan: aNumber
"Answer a string with the same content as receiver, but rewrapped so that no line has more characters than the given number"
| listOfLines currentLast currentStart resultString putativeLast putativeLine crPosition |
aNumber isNumber not | (aNumber < 1) ifTrue: [self error: 'too narrow'].
listOfLines _ OrderedCollection new.
currentLast _ 0.
[currentLast < self size] whileTrue:
[currentStart _ currentLast + 1.
putativeLast _ (currentStart + aNumber - 1) min: self size.
putativeLine _ self copyFrom: currentStart to: putativeLast.
(crPosition _ putativeLine indexOf: Character cr) > 0 ifTrue:
[putativeLast _ currentStart + crPosition - 1.
putativeLine _ self copyFrom: currentStart to: putativeLast].
currentLast _ putativeLast == self size
ifTrue:
[putativeLast]
ifFalse:
[currentStart + putativeLine lastSpacePosition - 1].
currentLast <= currentStart ifTrue:
["line has NO spaces; baleout!!"
currentLast _ putativeLast].
listOfLines add: (self copyFrom: currentStart to: currentLast) withBlanksTrimmed].
listOfLines size > 0 ifFalse: [^ ''].
resultString _ listOfLines first.
2 to: listOfLines size do:
[:i | resultString _ resultString, String cr, (listOfLines at: i)].
^ resultString
"#(5 7 20) collect:
[:i | 'Fred the bear went down to the brook to read his book in silence' withNoLineLongerThan: i]"!
----- Method: String>>withSeparatorsCompacted (in category 'converting') -----
withSeparatorsCompacted
"replace each sequences of whitespace by a single space character"
"' test ' withSeparatorsCompacted = ' test '"
"' test test' withSeparatorsCompacted = ' test test'"
"'test test ' withSeparatorsCompacted = 'test test '"
| out in next isSeparator |
self isEmpty ifTrue: [^ self].
out _ WriteStream on: (String new: self size).
in _ self readStream.
isSeparator _ [:char | char asciiValue < 256
and: [CSSeparators includes: char]].
[in atEnd] whileFalse: [
next _ in next.
(isSeparator value: next)
ifTrue: [
out nextPut: $ .
[in atEnd or:
[next _ in next.
(isSeparator value: next)
ifTrue: [false]
ifFalse: [out nextPut: next. true]]] whileFalse]
ifFalse: [out nextPut: next]].
^ out contents!
----- Method: String>>withSqueakLineEndings (in category 'internet') -----
withSqueakLineEndings
"assume the string is textual, and that CR, LF, and CRLF are all
valid line endings. Replace each occurence with a single CR"
| cr lf input c crlf inPos outPos outString lineEndPos newOutPos |
cr _ Character cr.
lf _ Character linefeed.
crlf _ CharacterSet new.
crlf add: cr; add: lf.
inPos _ 1.
outPos _ 1.
outString _
String new: self size.
[ lineEndPos _ self indexOfAnyOf: crlf startingAt: inPos ifAbsent: [0].
lineEndPos ~= 0 ] whileTrue: [
newOutPos _ outPos + (lineEndPos - inPos + 1).
outString replaceFrom: outPos to: newOutPos - 2 with: self startingAt: inPos.
outString at: newOutPos-1 put: cr.
outPos _ newOutPos.
((self at: lineEndPos) = cr and: [ lineEndPos < self size and: [ (self at: lineEndPos+1) = lf ] ]) ifTrue: [
"CRLF ending"
inPos _ lineEndPos + 2 ]
ifFalse: [
"CR or LF ending"
inPos _ lineEndPos + 1 ]. ].
"no more line endings. copy the rest"
newOutPos _ outPos + (self size - inPos + 1).
outString replaceFrom: outPos to: newOutPos-1 with: self startingAt: inPos.
^outString copyFrom: 1 to: newOutPos-1
!
----- Method: String>>withoutLeadingDigits (in category 'converting') -----
withoutLeadingDigits
"Answer the portion of the receiver that follows any leading series of digits and blanks. If the receiver consists entirely of digits and blanks, return an empty string"
| firstNonDigit |
firstNonDigit _ (self findFirst: [:m | m isDigit not and: [m ~= $ ]]).
^ firstNonDigit > 0
ifTrue:
[self copyFrom: firstNonDigit to: self size]
ifFalse:
['']
"
'234Whoopie' withoutLeadingDigits
' 4321 BlastOff!!' withoutLeadingDigits
'wimpy' withoutLeadingDigits
' 89Ten ' withoutLeadingDigits
'78 92' withoutLeadingDigits
"
!
----- Method: String>>withoutQuoting (in category 'internet') -----
withoutQuoting
"remove the initial and final quote marks, if present"
"'''h''' withoutQuoting"
| quote |
self size < 2 ifTrue: [ ^self ].
quote _ self first.
(quote = $' or: [ quote = $" ])
ifTrue: [ ^self copyFrom: 2 to: self size - 1 ]
ifFalse: [ ^self ].!
----- Method: String>>withoutTrailingBlanks (in category 'converting') -----
withoutTrailingBlanks
"Return a copy of the receiver from which trailing blanks have been trimmed."
| last |
last _ self findLast: [:c | c isSeparator not].
last = 0 ifTrue: [^ '']. "no non-separator character"
^ self copyFrom: 1 to: last
" ' abc d ' withoutTrailingBlanks"
!
----- Method: String>>withoutTrailingDigits (in category 'converting') -----
withoutTrailingDigits
"Answer the portion of the receiver that precedes any trailing series of digits and blanks. If the receiver consists entirely of digits and blanks, return an empty string"
| firstDigit |
firstDigit _ (self findFirst: [:m | m isDigit or: [m = $ ]]).
^ firstDigit > 0
ifTrue:
[self copyFrom: 1 to: firstDigit-1]
ifFalse:
[self]
"
'Whoopie234' withoutTrailingDigits
' 4321 BlastOff!!' withoutLeadingDigits
'wimpy' withoutLeadingDigits
' 89Ten ' withoutLeadingDigits
'78 92' withoutLeadingDigits
"
!
----- Method: String>>writeLeadingCharRunsOn: (in category 'encoding') -----
writeLeadingCharRunsOn: stream
| runLength runValues runStart leadingChar |
self isEmpty ifTrue: [^ self].
runLength _ OrderedCollection new.
runValues _ OrderedCollection new.
runStart _ 1.
leadingChar _ (self at: runStart) leadingChar.
2 to: self size do: [:index |
(self at: index) leadingChar = leadingChar ifFalse: [
runValues add: leadingChar.
runLength add: (index - runStart).
leadingChar _ (self at: index) leadingChar.
runStart _ index.
].
].
runValues add: (self last) leadingChar.
runLength add: self size + 1 - runStart.
stream nextPut: $(.
runLength do: [:rr | rr printOn: stream. stream space].
stream skip: -1; nextPut: $).
runValues do: [:vv | vv printOn: stream. stream nextPut: $,].
stream skip: -1.
!
String subclass: #Symbol
instanceVariableNames: ''
classVariableNames: 'NewSymbols OneCharacterSymbols SymbolTable'
poolDictionaries: ''
category: 'Collections-Strings'!
!Symbol commentStamp: '<historical>' prior: 0!
I represent Strings that are created uniquely. Thus, someString asSymbol == someString asSymbol.!
Symbol variableByteSubclass: #ByteSymbol
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Strings'!
!ByteSymbol commentStamp: '<historical>' prior: 0!
This class represents the symbols containing 8bit characters.!
----- Method: ByteSymbol class>>findFirstInString:inSet:startingAt: (in category 'primitives') -----
findFirstInString: aString inSet: inclusionMap startingAt: start
^ByteString findFirstInString: aString inSet: inclusionMap startingAt: start!
----- Method: ByteSymbol class>>indexOfAscii:inString:startingAt: (in category 'primitives') -----
indexOfAscii: anInteger inString: aString startingAt: start
^ByteString indexOfAscii: anInteger inString: aString startingAt: start!
----- Method: ByteSymbol class>>stringHash:initialHash: (in category 'primitives') -----
stringHash: aString initialHash: speciesHash
<primitive: 'primitiveStringHash' module: 'MiscPrimitivePlugin'>
^ ByteString class stringHash: aString initialHash: speciesHash.
!
----- Method: ByteSymbol class>>translate:from:to:table: (in category 'primitives') -----
translate: aString from: start to: stop table: table
^ByteString translate: aString from: start to: stop table: table!
----- Method: ByteSymbol>>asByteArray (in category 'converting') -----
asByteArray
| ba sz |
sz := self byteSize.
ba := ByteArray new: sz.
ba replaceFrom: 1 to: sz with: self startingAt: 1.
^ba!
----- Method: ByteSymbol>>asOctetString (in category 'converting') -----
asOctetString
^ self!
----- Method: ByteSymbol>>at: (in category '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)!
----- Method: ByteSymbol>>at:put: (in category 'accessing') -----
at: anInteger put: anObject
"You cannot modify the receiver."
self errorNoModification!
----- Method: ByteSymbol>>byteAt: (in category 'accessing') -----
byteAt: index
<primitive: 60>
^(self at: index) asciiValue!
----- Method: ByteSymbol>>byteAt:put: (in category 'accessing') -----
byteAt: anInteger put: anObject
"You cannot modify the receiver."
self errorNoModification!
----- Method: ByteSymbol>>byteSize (in category 'accessing') -----
byteSize
^self size!
----- Method: ByteSymbol>>findSubstring:in:startingAt:matchTable: (in category 'comparing') -----
findSubstring: key in: body startingAt: start matchTable: matchTable
"Answer the index in the string body at which the substring key first occurs, at or beyond start. The match is determined using matchTable, which can be used to effect, eg, case-insensitive matches. If no match is found, zero will be returned."
<primitive: 'primitiveFindSubstring' module: 'MiscPrimitivePlugin'>
^super findSubstring: key in: body startingAt: start matchTable: matchTable!
----- Method: ByteSymbol>>isByteString (in category 'testing') -----
isByteString
"Answer whether the receiver is a ByteString"
^true!
----- Method: ByteSymbol>>isOctetString (in category 'testing') -----
isOctetString
"Answer whether the receiver can be represented as a byte string.
This is different from asking whether the receiver *is* a ByteString
(i.e., #isByteString)"
^ true.
!
----- Method: ByteSymbol>>pvtAt:put: (in category 'private') -----
pvtAt: 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 isCharacter
ifFalse:[^self errorImproperStore].
index isInteger
ifTrue: [self errorSubscriptBounds: index]
ifFalse: [self errorNonIntegerIndex]!
----- Method: ByteSymbol>>species (in category 'accessing') -----
species
"Answer the preferred class for reconstructing the receiver."
^ByteString
!
----- Method: ByteSymbol>>string: (in category 'private') -----
string: aString
1 to: aString size do: [:j | self pvtAt: j put: (aString at: j)].
^self!
----- Method: Symbol class>>allSymbolTablesDo: (in category 'class initialization') -----
allSymbolTablesDo: aBlock
NewSymbols do: aBlock.
SymbolTable do: aBlock.!
----- Method: Symbol class>>allSymbolTablesDo:after: (in category 'class initialization') -----
allSymbolTablesDo: aBlock after: aSymbol
NewSymbols do: aBlock after: aSymbol.
SymbolTable do: aBlock after: aSymbol.!
----- Method: Symbol class>>allSymbols (in category 'access') -----
allSymbols
"Answer all interned symbols"
^Array streamContents:[:s|
s nextPutAll: NewSymbols.
s nextPutAll: OneCharacterSymbols.
s nextPutAll: SymbolTable.
].
!
----- Method: Symbol class>>compactSymbolTable (in category 'class initialization') -----
compactSymbolTable
"Reduce the size of the symbol table so that it holds all existing symbols + 25% (changed from 1000 since sets like to have 25% free and the extra space would grow back in a hurry)"
| oldSize |
Smalltalk garbageCollect.
oldSize _ SymbolTable array size.
SymbolTable growTo: SymbolTable size * 4 // 3 + 100.
^oldSize printString,' ',(oldSize - SymbolTable array size) printString, ' slot(s) reclaimed'!
----- Method: Symbol class>>compareTiming (in category 'class initialization') -----
compareTiming
"
Symbol compareTiming
"
| answer t selectorList implementorLists flattenedList md |
answer _ WriteStream on: String new.
SmalltalkImage current timeStamp: answer.
answer cr; cr.
answer nextPutAll: MethodDictionary instanceCount printString , ' method dictionaries';
cr;
cr.
answer nextPutAll: (MethodDictionary allInstances
inject: 0
into: [:sum :each | sum + each size]) printString , ' method dictionary entries';
cr;
cr.
md _ MethodDictionary allInstances.
t _ [100
timesRepeat: [md
do: [:each | each includesKey: #majorShrink]]] timeToRun.
answer nextPutAll: t printString , ' ms to check all method dictionaries for #majorShrink 1000 times';
cr;
cr.
selectorList _ Symbol selectorsContaining: 'help'.
t _ [3
timesRepeat: [selectorList
collect: [:each | self systemNavigation allImplementorsOf: each]]] timeToRun.
answer nextPutAll: t printString , ' ms to do #allImplementorsOf: for ' , selectorList size printString , ' selectors like *help* 3 times';
cr;
cr.
t _ [3
timesRepeat: [selectorList
do: [:eachSel | md
do: [:eachMd | eachMd includesKey: eachSel]]]] timeToRun.
answer nextPutAll: t printString , ' ms to do #includesKey: for ' , md size printString , ' methodDicts for ' , selectorList size printString , ' selectors like *help* 3 times';
cr;
cr.
#('help' 'majorShrink' )
do: [:substr |
answer nextPutAll: (Symbol selectorsContaining: substr) size printString , ' selectors containing "' , substr , '"';
cr.
t _ [3
timesRepeat: [selectorList _ Symbol selectorsContaining: substr]] timeToRun.
answer nextPutAll: t printString , ' ms to find Symbols containing *' , substr , '* 3 times';
cr.
t _ [3
timesRepeat: [selectorList _ Symbol selectorsContaining: substr.
implementorLists _ selectorList
collect: [:each | Smalltalk allImplementorsOf: each].
flattenedList _ SortedCollection new.
implementorLists
do: [:each | flattenedList addAll: each]]] timeToRun.
answer nextPutAll: t printString , ' ms to find implementors of *' , substr , '* 3 times';
cr;
cr].
StringHolder new contents: answer contents;
openLabel: 'timing'!
----- Method: Symbol class>>findInterned: (in category 'instance creation') -----
findInterned: aString
self hasInterned: aString ifTrue: [:symbol | ^symbol].
^nil.!
----- Method: Symbol class>>hasInterned:ifTrue: (in category 'private') -----
hasInterned: aString ifTrue: symBlock
"Answer with false if aString hasnt been interned (into a Symbol),
otherwise supply the symbol to symBlock and return true."
| symbol |
^ (symbol _ self lookup: aString)
ifNil: [false]
ifNotNil: [symBlock value: symbol.
true]!
----- Method: Symbol class>>initialize (in category 'class initialization') -----
initialize
"Symbol initialize"
Symbol rehash.
OneCharacterSymbols _ nil.
OneCharacterSymbols _ (1 to: 256) collect: [ :i | (i - 1) asCharacter asSymbol].
Smalltalk addToShutDownList: self.
!
----- Method: Symbol class>>intern: (in category 'instance creation') -----
intern: aStringOrSymbol
^(self lookup: aStringOrSymbol) ifNil:[
| aClass aSymbol |
aStringOrSymbol isSymbol ifTrue:[
aSymbol _ aStringOrSymbol.
] ifFalse:[
aClass := aStringOrSymbol isOctetString ifTrue:[ByteSymbol] ifFalse:[WideSymbol].
aSymbol := aClass new: aStringOrSymbol size.
aSymbol string: aStringOrSymbol.
].
NewSymbols add: aSymbol.
aSymbol].!
----- Method: Symbol class>>internCharacter: (in category 'instance creation') -----
internCharacter: aCharacter
aCharacter asciiValue > 256 ifTrue:[^self intern: aCharacter asString].
OneCharacterSymbols ifNil: [^self intern: aCharacter asString].
^OneCharacterSymbols at: aCharacter asciiValue + 1
!
----- Method: Symbol class>>lookup: (in category 'instance creation') -----
lookup: aStringOrSymbol
^(SymbolTable like: aStringOrSymbol) ifNil: [
NewSymbols like: aStringOrSymbol
]!
----- Method: Symbol class>>newFrom: (in category 'instance creation') -----
newFrom: aCollection
"Answer an instance of me containing the same elements as aCollection."
^ (aCollection as: String) asSymbol
" Symbol newFrom: {$P. $e. $n}
{$P. $e. $n} as: Symbol
"!
----- Method: Symbol class>>possibleSelectorsFor: (in category 'private') -----
possibleSelectorsFor: misspelled
"Answer an ordered collection of possible corrections
for the misspelled selector in order of likelyhood"
| numArgs candidates lookupString best binary short long first ss |
lookupString _ misspelled asLowercase. "correct uppercase selectors to lowercase"
numArgs _ lookupString numArgs.
(numArgs < 0 or: [lookupString size < 2]) ifTrue: [^ OrderedCollection new: 0].
first _ lookupString first.
short _ lookupString size - (lookupString size // 4 max: 3) max: 2.
long _ lookupString size + (lookupString size // 4 max: 3).
"First assemble candidates for detailed scoring"
candidates _ OrderedCollection new.
self allSymbolTablesDo: [:s | (((ss _ s size) >= short "not too short"
and: [ss <= long "not too long"
or: [(s at: 1) = first]]) "well, any length OK if starts w/same letter"
and: [s numArgs = numArgs]) "and numArgs is the same"
ifTrue: [candidates add: s]].
"Then further prune these by correctAgainst:"
best _ lookupString correctAgainst: candidates.
((misspelled last ~~ $:) and: [misspelled size > 1]) ifTrue: [
binary _ misspelled, ':'. "try for missing colon"
Symbol hasInterned: binary ifTrue: [:him | best addFirst: him]].
^ best!
----- Method: Symbol class>>readFrom: (in category 'instance creation') -----
readFrom: strm "Symbol readFromString: '#abc'"
strm peek = $# ifFalse: [self error: 'Symbols must be introduced by #'].
^ (Scanner new scan: strm) advance "Just do what the code scanner does"!
----- Method: Symbol class>>rehash (in category 'private') -----
rehash "Symbol rehash"
"Rebuild the hash table, reclaiming unreferenced Symbols."
SymbolTable := WeakSet withAll: self allSubInstances.
NewSymbols := WeakSet new.!
----- Method: Symbol class>>selectorsContaining: (in category 'access') -----
selectorsContaining: aString
"Answer a list of selectors that contain aString within them. Case-insensitive. Does return symbols that begin with a capital letter."
| size selectorList ascii |
selectorList _ OrderedCollection new.
(size _ aString size) = 0 ifTrue: [^selectorList].
aString size = 1 ifTrue:
[
ascii _ aString first asciiValue.
ascii < 128 ifTrue: [selectorList add: (OneCharacterSymbols at: ascii+1)]
].
aString first isLetter ifFalse:
[
aString size == 2 ifTrue:
[Symbol hasInterned: aString ifTrue:
[:s | selectorList add: s]].
^selectorList
].
selectorList _ selectorList copyFrom: 2 to: selectorList size.
self allSymbolTablesDo: [:each |
each size >= size ifTrue:
[(each findSubstring: aString in: each startingAt: 1
matchTable: CaseInsensitiveOrder) > 0
ifTrue: [selectorList add: each]]].
^selectorList reject: [:each | "reject non-selectors, but keep ones that begin with an uppercase"
each numArgs < 0 and: [each asString withFirstCharacterDownshifted numArgs < 0]].
"Symbol selectorsContaining: 'scon'"!
----- Method: Symbol class>>shutDown: (in category 'private') -----
shutDown: aboutToQuit
SymbolTable addAll: NewSymbols.
NewSymbols _ WeakSet new.!
----- Method: Symbol class>>thatStarts:skipping: (in category 'access') -----
thatStarts: leadingCharacters skipping: skipSym
"Answer a selector symbol that starts with leadingCharacters.
Symbols beginning with a lower-case letter handled directly here.
Ignore case after first char.
If skipSym is not nil, it is a previous answer; start searching after it.
If no symbols are found, answer nil.
Used by Alt-q (Command-q) routines"
| size firstMatch key |
size _ leadingCharacters size.
size = 0 ifTrue: [^skipSym ifNil: [#''] ifNotNil: [nil]].
firstMatch _ leadingCharacters at: 1.
size > 1 ifTrue: [key _ leadingCharacters copyFrom: 2 to: size].
self allSymbolTablesDo: [:each |
each size >= size ifTrue:
[
((each at: 1) == firstMatch and:
[key == nil or:
[(each findString: key startingAt: 2 caseSensitive: false) = 2]])
ifTrue: [^each]
]
] after: skipSym.
^nil
"Symbol thatStarts: 'sf' skipping: nil"
"Symbol thatStarts: 'sf' skipping: #sfpGetFile:with:with:with:with:with:with:with:with:"
"Symbol thatStarts: 'candidate' skipping: nil"
!
----- Method: Symbol class>>thatStartsCaseSensitive:skipping: (in category 'access') -----
thatStartsCaseSensitive: leadingCharacters skipping: skipSym
"Same as thatStarts:skipping: but caseSensitive"
| size firstMatch key |
size := leadingCharacters size.
size = 0 ifTrue: [^skipSym ifNil: [#''] ifNotNil: [nil]].
firstMatch := leadingCharacters at: 1.
size > 1 ifTrue: [key := leadingCharacters copyFrom: 2 to: size].
self allSymbolTablesDo: [:each |
each size >= size ifTrue:
[
((each at: 1) == firstMatch and:
[key == nil or:
[(each findString: key startingAt: 2 caseSensitive: true) = 2]])
ifTrue: [^each]
]
] after: skipSym.
^nil
!
----- Method: Symbol>>= (in category 'comparing') -----
= aSymbol
"Compare the receiver and aSymbol."
self == aSymbol ifTrue: [^ true].
self class == aSymbol class ifTrue: [^ false].
"Use String comparison otherwise"
^ super = aSymbol!
----- Method: Symbol>>asExplorerString (in category 'user interface') -----
asExplorerString
^ self printString!
----- Method: Symbol>>asMutator (in category 'converting') -----
asMutator
"Return a setter message from a getter message. For example,
#name asMutator returns #name:"
^ (self copyWith: $:) asSymbol!
----- Method: Symbol>>asString (in category 'converting') -----
asString
"Refer to the comment in String|asString."
| newString |
newString _ self species new: self size.
newString replaceFrom: 1 to: newString size with: self startingAt: 1.
^newString!
----- Method: Symbol>>asSymbol (in category 'converting') -----
asSymbol
"Refer to the comment in String|asSymbol."!
----- Method: Symbol>>at:put: (in category 'accessing') -----
at: anInteger put: anObject
"You cannot modify the receiver."
self errorNoModification!
----- Method: Symbol>>byteEncode: (in category 'filter streaming') -----
byteEncode:aStream
^aStream writeSymbol:self.
!
----- Method: Symbol>>capitalized (in category 'converting') -----
capitalized
^ self asString capitalized asSymbol!
----- Method: Symbol>>clone (in category 'copying') -----
clone
"Answer with the receiver, because Symbols are unique."!
----- Method: Symbol>>copy (in category 'copying') -----
copy
"Answer with the receiver, because Symbols are unique."!
----- Method: Symbol>>errorNoModification (in category 'private') -----
errorNoModification
self error: 'symbols can not be modified.'!
----- Method: Symbol>>flushCache (in category 'system primitives') -----
flushCache
"Tell the interpreter to remove all entries with this symbol as a selector from its method lookup cache, if it has one. This primitive must be called whenever a method is defined or removed.
NOTE: Only one of the two selective flush methods needs to be used.
Squeak 2.3 and later uses 116 (See CompiledMethod flushCache)."
<primitive: 119>
!
----- Method: Symbol>>isDoIt (in category 'testing') -----
isDoIt
^ (self == #DoIt) or: [self == #DoItIn:].!
----- Method: Symbol>>isInfix (in category 'testing') -----
isInfix
"Answer whether the receiver is an infix message selector."
^ self precedence == 2!
----- Method: Symbol>>isKeyword (in category 'testing') -----
isKeyword
"Answer whether the receiver is a message keyword."
^ self precedence == 3!
----- Method: Symbol>>isLiteral (in category 'testing') -----
isLiteral
"Answer whether the receiver is a valid Smalltalk literal."
^ true!
----- Method: Symbol>>isOrientedFill (in category 'printing') -----
isOrientedFill
"Needs to be implemented here because symbols can occupy 'color' slots of morphs."
^ false!
----- Method: Symbol>>isPvtSelector (in category 'testing') -----
isPvtSelector
"Answer whether the receiver is a private message selector, that is,
begins with 'pvt' followed by an uppercase letter, e.g. pvtStringhash."
^ (self beginsWith: 'pvt') and: [self size >= 4 and: [(self at: 4) isUppercase]]!
----- Method: Symbol>>isReallyString (in category 'testing') -----
isReallyString
^ false!
----- Method: Symbol>>isSymbol (in category 'testing') -----
isSymbol
^ true !
----- Method: Symbol>>isUnary (in category 'testing') -----
isUnary
"Answer whether the receiver is an unary message selector."
^ self precedence == 1!
----- Method: Symbol>>literalStringsDo: (in category 'translating') -----
literalStringsDo: aBlock
"Assuming the receiver receiver is a literal, evaluate aBlock with all Strings (but not Symbols) within it."
^ self!
----- Method: Symbol>>precedence (in category 'accessing') -----
precedence
"Answer the receiver's precedence, assuming it is a valid Smalltalk
message selector or 0 otherwise. The numbers are 1 for unary,
2 for binary and 3 for keyword selectors."
self size = 0 ifTrue: [^ 0].
self first isLetter ifFalse: [^ 2].
self last = $: ifTrue: [^ 3].
^ 1!
----- Method: Symbol>>replaceFrom:to:with:startingAt: (in category 'accessing') -----
replaceFrom: start to: stop with: replacement startingAt: repStart
self errorNoModification!
----- Method: Symbol>>shallowCopy (in category 'copying') -----
shallowCopy
"Answer with the receiver, because Symbols are unique."!
----- Method: Symbol>>storeOn: (in category 'printing') -----
storeOn: aStream
aStream nextPut: $#.
(Scanner isLiteralSymbol: self)
ifTrue: [aStream nextPutAll: self]
ifFalse: [super storeOn: aStream]!
----- Method: Symbol>>string: (in category 'private') -----
string: aString
1 to: aString size do: [:j | super at: j put: (aString at: j)].
^self !
----- Method: Symbol>>sunitAsClass (in category 'Camp Smalltalk') -----
sunitAsClass
^SUnitNameResolver classNamed: self!
----- Method: Symbol>>veryDeepCopyWith: (in category 'copying') -----
veryDeepCopyWith: deepCopier
"Return self. I am immutable in the Morphic world. Do not record me."!
----- Method: Symbol>>withFirstCharacterDownshifted (in category 'converting') -----
withFirstCharacterDownshifted
"Answer an object like the receiver but with first character downshifted if necesary"
^self asString withFirstCharacterDownshifted asSymbol.!
Symbol variableWordSubclass: #WideSymbol
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Strings'!
!WideSymbol commentStamp: '<historical>' prior: 0!
This class represents the symbols containing 32bit characters.!
----- Method: WideSymbol class>>initialize (in category 'class initialization') -----
initialize
Smalltalk removeFromShutDownList: self. "@@@ Remove this later @@@"!
----- Method: WideSymbol class>>newFromStream: (in category 'instance creation') -----
newFromStream: s
"Use WideString rather than 'super' to avoid making multiple instance of WideSymbol"
^ self
intern: (WideString newFromStream: s)!
----- Method: WideSymbol>>at: (in category 'accessing') -----
at: index
"Answer the Character stored in the field of the receiver indexed by the argument."
^ Character value: (self wordAt: index).
!
----- Method: WideSymbol>>at:put: (in category 'accessing') -----
at: anInteger put: anObject
"You cannot modify the receiver."
self errorNoModification
!
----- Method: WideSymbol>>byteAt: (in category 'accessing') -----
byteAt: index
| d r |
d _ (index + 3) // 4.
r _ (index - 1) \\ 4 + 1.
^ (self wordAt: d) digitAt: ((4 - r) + 1).
!
----- Method: WideSymbol>>byteAt:put: (in category 'accessing') -----
byteAt: index put: aByte
self errorNoModification.!
----- Method: WideSymbol>>byteSize (in category 'accessing') -----
byteSize
^ self size * 4.
!
----- Method: WideSymbol>>fixUponLoad:seg: (in category 'private') -----
fixUponLoad: aProject seg: anImageSegment
"We are in an old project that is being loaded from disk.
Fix up conventions that have changed."
| ms |
"Yoshiki did not put MultiSymbols into outPointers in older
images!!
When all old images are gone, remove this method."
ms _ Symbol intern: self asString.
self == ms ifFalse: [
"For a project from older m17n image, this is necessary."
self becomeForward: ms.
aProject projectParameters at: #MultiSymbolInWrongPlace put: true
].
"MultiString>>capitalized was not implemented
correctly.
Fix eventual accessors and mutators here."
((self beginsWith: 'get')
and:[(self at: 4) asInteger < 256
and:[(self at: 4) isLowercase]]) ifTrue:[
ms _ self asString.
ms at: 4 put: (ms at: 4) asUppercase.
ms _ ms asSymbol.
self becomeForward: ms.
aProject projectParameters at: #MultiSymbolInWrongPlace put: true.
].
((self beginsWith: 'set')
and:[(self at: 4) asInteger < 256
and:[(self at: 4) isLowercase
and:[self last = $:
and:[(self occurrencesOf: $:) = 1]]]]) ifTrue:[
ms _ self asString.
ms at: 4 put: (ms at: 4) asUppercase.
ms _ ms asSymbol.
self becomeForward: ms.
aProject projectParameters at: #MultiSymbolInWrongPlace put: true.
].
^ super fixUponLoad: aProject seg: anImageSegment "me,
not the label"
!
----- Method: WideSymbol>>isWideString (in category 'testing') -----
isWideString
"Answer whether the receiver is a WideString"
^true!
----- Method: WideSymbol>>mutateJISX0208StringToUnicode (in category 'private') -----
mutateJISX0208StringToUnicode
| c |
1 to: self size do: [:i |
c _ self at: i.
(c leadingChar = JISX0208 leadingChar or: [
c leadingChar = (JISX0208 leadingChar bitShift: 2)]) ifTrue: [
self basicAt: i put: (Character leadingChar: JapaneseEnvironment leadingChar code: (c asUnicode)) asciiValue.
]
].
!
----- Method: WideSymbol>>pvtAt:put: (in category 'private') -----
pvtAt: 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: 61>
index isInteger
ifTrue: [self errorSubscriptBounds: index]
ifFalse: [self errorNonIntegerIndex]!
----- Method: WideSymbol>>species (in category 'accessing') -----
species
"Answer the preferred class for reconstructing the receiver."
^WideString
!
----- Method: WideSymbol>>string: (in category 'private') -----
string: aString
1 to: aString size do: [:j | self pvtAt: j put: (aString at: j) asInteger].
^self!
----- Method: WideSymbol>>wordAt: (in category 'accessing') -----
wordAt: index
<primitive: 60>
^ (self basicAt: index).
!
----- Method: WideSymbol>>wordAt:put: (in category 'accessing') -----
wordAt: index put: anInteger
self errorNoModification.!
String variableWordSubclass: #WideString
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Strings'!
!WideString commentStamp: 'yo 10/19/2004 22:34' prior: 0!
This class represents the array of 32 bit wide characters.
!
----- Method: WideString class>>allMethodsWithEncodingTag: (in category 'enumeration') -----
allMethodsWithEncodingTag: encodingTag
"Answer a SortedCollection of all the methods that implement the message
aSelector."
| list adder num i |
list _ Set new.
adder _ [ :mrClass :mrSel |
list add: (
MethodReference new
setStandardClass: mrClass
methodSymbol: mrSel
)
].
num _ CompiledMethod allInstances size.
i _ 0.
'processing...' displayProgressAt: Sensor cursorPoint from: 0 to: num during: [:bar |
SystemNavigation new allBehaviorsDo: [ :class |
class selectors do: [:s |
bar value: (i _ i + 1).
(self string: (class sourceCodeAt: s) asString hasEncoding: encodingTag) ifTrue: [
adder value: class value: s.
]
]
]
].
^ list.
!
----- Method: WideString class>>allMultiStringMethods (in category 'enumeration') -----
allMultiStringMethods
"Answer a SortedCollection of all the methods that implement the message
aSelector."
| list adder num i |
list _ Set new.
adder _ [ :mrClass :mrSel |
list add: (
MethodReference new
setStandardClass: mrClass
methodSymbol: mrSel
)
].
num _ CompiledMethod allInstances size.
i _ 0.
'processing...' displayProgressAt: Sensor cursorPoint from: 0 to: num during: [:bar |
SystemNavigation new allBehaviorsDo: [ :class |
class selectors do: [:s |
bar value: (i _ i + 1).
((class sourceCodeAt: s) asString isOctetString) ifFalse: [
adder value: class value: s.
]
]
]
].
^ list.
!
----- Method: WideString class>>allNonAsciiMethods (in category 'enumeration') -----
allNonAsciiMethods
"Answer a SortedCollection of all the methods that implement the message
aSelector."
| list adder num i |
list _ Set new.
adder _ [ :mrClass :mrSel |
list add: (
MethodReference new
setStandardClass: mrClass
methodSymbol: mrSel
)
].
num _ CompiledMethod allInstances size.
i _ 0.
'processing...' displayProgressAt: Sensor cursorPoint from: 0 to: num during: [:bar |
SystemNavigation new allBehaviorsDo: [ :class |
class selectors do: [:s |
bar value: (i _ i + 1).
((class sourceCodeAt: s) asString isAsciiString) ifFalse: [
adder value: class value: s.
]
]
]
].
^ list.
!
----- Method: WideString class>>findFirstInString:inSet:startingAt: (in category 'primitives') -----
findFirstInString: aString inSet: inclusionMap startingAt: start
| i stringSize ascii more |
self var: #aString declareC: 'unsigned int *aString'.
self var: #inclusionMap declareC: 'char *inclusionMap'.
inclusionMap size ~= 256 ifTrue: [^ 0].
stringSize _ aString size.
more _ true.
i _ start - 1.
[more and: [i + 1 <= stringSize]] whileTrue: [
i _ i + 1.
ascii _ (aString at: i) asciiValue.
more _ ascii < 256 ifTrue: [(inclusionMap at: ascii + 1) = 0] ifFalse: [true].
].
i + 1 > stringSize ifTrue: [^ 0].
^ i.
!
----- Method: WideString class>>from: (in category 'instance creation') -----
from: aString
| newString |
(aString isMemberOf: self)
ifTrue: [^ aString copy].
newString _ self new: aString size.
1 to: aString size do: [:index | newString basicAt: index put: (aString basicAt: index)].
^ newString
!
----- Method: WideString class>>fromByteArray: (in category 'instance creation') -----
fromByteArray: aByteArray
| inst |
aByteArray size \\ 4 = 0 ifFalse: [^ ByteString fromByteArray: aByteArray ].
inst _ self new: aByteArray size // 4.
4 to: aByteArray size by: 4 do: [:i |
inst basicAt: i // 4
put: ((aByteArray at: i - 3) << 24) +
((aByteArray at: i - 2) << 16) +
((aByteArray at: i - 1) << 8) +
(aByteArray at: i)
].
^ inst
!
----- Method: WideString class>>fromISO2022JPString: (in category 'instance creation') -----
fromISO2022JPString: string
| tempFileName stream contents |
tempFileName _ Time millisecondClockValue printString , '.txt'.
FileDirectory default deleteFileNamed: tempFileName ifAbsent: [].
stream _ StandardFileStream fileNamed: tempFileName.
[stream nextPutAll: string]
ensure: [stream close].
stream _ FileStream fileNamed: tempFileName.
contents _ stream contentsOfEntireFile.
FileDirectory default deleteFileNamed: tempFileName ifAbsent: [].
^ contents
!
----- Method: WideString class>>fromPacked: (in category 'instance creation') -----
fromPacked: aLong
"Convert from a longinteger to a String of length 4."
| s val |
s _ self new: 1.
val _ (((aLong digitAt: 4) << 24) bitOr:((aLong digitAt: 3) << 16))
bitOr: (((aLong digitAt: 2) << 8) bitOr: (aLong digitAt: 1)).
s basicAt: 1 put: val.
^ s.
"WideString fromPacked: 'TEXT' asPacked"
!
----- Method: WideString class>>fromString: (in category 'instance creation') -----
fromString: aString
"Answer an instance of me that is a copy of the argument, aString."
| inst |
(aString isMemberOf: self) ifTrue: [
^ aString copy.
].
inst _ self new: aString size.
1 to: aString size do: [:pos |
inst basicAt: pos put: (aString basicAt: pos).
].
^ inst.
!
----- Method: WideString class>>indexOfAscii:inString:startingAt: (in category 'primitives') -----
indexOfAscii: anInteger inString: aString startingAt: start
| stringSize |
self var: #aCharacter declareC: 'int anInteger'.
self var: #aString declareC: 'unsigned int *aString'.
stringSize _ aString size.
start to: stringSize do: [:pos |
(aString at: pos) asciiValue = anInteger ifTrue: [^ pos]].
^ 0
!
----- Method: WideString class>>stringHash:initialHash: (in category 'primitives') -----
stringHash: aString initialHash: speciesHash
| stringSize hash low |
self var: #aHash declareC: 'int speciesHash'.
self var: #aString declareC: 'unsigned int *aString'.
stringSize _ aString size.
hash _ speciesHash bitAnd: 16rFFFFFFF.
1 to: stringSize do: [:pos |
hash _ hash + (aString at: pos) asciiValue.
"Begin hashMultiply"
low _ hash bitAnd: 16383.
hash _ (16r260D * low + ((16r260D * (hash bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384)) bitAnd: 16r0FFFFFFF.
].
^ hash.
!
----- Method: WideString class>>translate:from:to:table: (in category 'primitives') -----
translate: aString from: start to: stop table: table
"translate the characters in the string by the given table, in place"
| char |
self var: #table declareC: 'unsigned char *table'.
self var: #aString declareC: 'unsigned int *aString'.
start to: stop do: [:i |
char _ aString basicAt: i.
char < 256 ifTrue: [
aString basicAt: i put: (table at: char+1) asciiValue
].
].
!
----- Method: WideString>>asFourCode (in category 'converting') -----
asFourCode
| result |
self size = 1 ifFalse: [^self error: 'must be exactly four octets'].
result _ self basicAt: 1.
(result bitAnd: 16r80000000) = 0
ifFalse: [self error: 'cannot resolve fourcode'].
(result bitAnd: 16r40000000) = 0 ifFalse: [^result - 16r80000000].
^ result
!
----- Method: WideString>>asPacked (in category 'converting') -----
asPacked
self inject: 0 into: [:pack :next | pack _ pack * 16r100000000 + next asInteger].
!
----- Method: WideString>>at: (in category 'accessing') -----
at: index
"Answer the Character stored in the field of the receiver indexed by the argument."
^ Character value: (self wordAt: index).
!
----- Method: WideString>>at:put: (in category 'accessing') -----
at: index put: aCharacter
"Store the Character in the field of the receiver indicated by the index."
aCharacter isCharacter ifFalse:[self errorImproperStore].
self wordAt: index put: aCharacter asInteger.
!
----- Method: WideString>>byteAt: (in category 'accessing') -----
byteAt: index
| d r |
d _ (index + 3) // 4.
r _ (index - 1) \\ 4 + 1.
^ (self wordAt: d) digitAt: ((4 - r) + 1).
!
----- Method: WideString>>byteAt:put: (in category 'accessing') -----
byteAt: index put: aByte
| d r w |
d _ (index + 3) // 4.
r _ (index - 1) \\ 4 + 1.
w _ (self wordAt: d) bitAnd: ((16rFF<<((4 - r)*8)) bitInvert32).
w _ w + (aByte<<((4 - r)*8)).
self basicAt: d put: w.
^ aByte.
!
----- Method: WideString>>byteSize (in category 'accessing') -----
byteSize
^ self size * 4.
!
----- Method: WideString>>copyFrom:to: (in category 'converting') -----
copyFrom: start to: stop
| n |
n _ super copyFrom: start to: stop.
n isOctetString ifTrue: [^ n asOctetString].
^ n.
!
----- Method: WideString>>includesUnifiedCharacter (in category 'testing') -----
includesUnifiedCharacter
^ self isUnicodeStringWithCJK
!
----- Method: WideString>>isUnicodeStringWithCJK (in category 'testing') -----
isUnicodeStringWithCJK
self do: [:c |
(c isTraditionalDomestic not and: [Unicode isUnifiedKanji: c charCode]) ifTrue: [
^ true
].
].
^ false.
!
----- Method: WideString>>isWideString (in category 'testing') -----
isWideString
"Answer whether the receiver is a WideString"
^true!
----- Method: WideString>>mutateJISX0208StringToUnicode (in category 'private') -----
mutateJISX0208StringToUnicode
| c |
1 to: self size do: [:i |
c _ self at: i.
(c leadingChar = JISX0208 leadingChar or: [
c leadingChar = (JISX0208 leadingChar bitShift: 2)]) ifTrue: [
self basicAt: i put: (Character leadingChar: JapaneseEnvironment leadingChar code: (c asUnicode)) asciiValue.
]
].
!
----- Method: WideString>>replaceFrom:to:with:startingAt: (in category 'accessing') -----
replaceFrom: start to: stop with: replacement startingAt: repStart
<primitive: 105>
replacement class == String ifTrue: [
^ self replaceFrom: start to: stop with: (replacement asWideString) startingAt: repStart.
].
^ super replaceFrom: start to: stop with: replacement startingAt: repStart.
!
----- Method: WideString>>wordAt: (in category 'accessing') -----
wordAt: index
<primitive: 60>
^ (self basicAt: index).
!
----- Method: WideString>>wordAt:put: (in category 'accessing') -----
wordAt: index put: anInteger
<primitive: 61>
self basicAt: index put: anInteger.
!
ArrayedCollection variableWordSubclass: #WordArray
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Arrayed'!
!WordArray commentStamp: '<historical>' prior: 0!
WordArrays store 32-bit unsigned Integer values.
!
----- Method: WordArray class>>bobsTest (in category 'as yet unclassified') -----
bobsTest
| wa s1 s2 wa2 answer rawData |
"
WordArray bobsTest
"
answer _ OrderedCollection new.
wa _ WordArray with: 16r01020304 with: 16r05060708.
{false. true} do: [ :pad |
0 to: 3 do: [ :skip |
s1 _ RWBinaryOrTextStream on: ByteArray new.
s1 next: skip put: 0. "start at varying positions"
wa writeOn: s1.
pad ifTrue: [s1 next: 4-skip put: 0]. "force length to be multiple of 4"
rawData _ s1 contents.
s2 _ RWBinaryOrTextStream with: rawData.
s2 reset.
s2 skip: skip. "get to beginning of object"
wa2 _ WordArray newFromStream: s2.
answer add: {
rawData size.
skip.
wa2 = wa.
wa2 asArray collect: [ :each | each radix: 16]
}
].
].
^answer explore!
----- Method: WordArray class>>ccg:emitLoadFor:from:on: (in category 'plugin generation') -----
ccg: cg emitLoadFor: aString from: anInteger on: aStream
cg emitLoad: aString asIntPtrFrom: anInteger on: aStream!
----- Method: WordArray class>>ccg:prolog:expr:index: (in category 'plugin generation') -----
ccg: cg prolog: aBlock expr: aString index: anInteger
^cg
ccgLoad: aBlock
expr: aString
asUnsignedPtrFrom: anInteger
andThen: (cg ccgValBlock: 'isWords')!
----- Method: WordArray class>>ccgDeclareCForVar: (in category 'plugin generation') -----
ccgDeclareCForVar: aSymbolOrString
^'unsigned *', aSymbolOrString!
----- Method: WordArray>>asWordArray (in category 'converting') -----
asWordArray
^self!
----- Method: WordArray>>atAllPut: (in category 'accessing') -----
atAllPut: value
"Fill the receiver with the given value"
<primitive: 145>
super atAllPut: value!
----- Method: WordArray>>byteSize (in category 'accessing') -----
byteSize
^self size * 4!
----- Method: WordArray>>bytesPerElement (in category 'accessing') -----
bytesPerElement
"Number of bytes in each item. This multiplied by (self size)*8 gives the number of bits stored."
^ 4!
----- Method: WordArray>>defaultElement (in category 'accessing') -----
defaultElement
"Return the default element of the receiver"
^0!
----- Method: WordArray>>eToysEQ: (in category 'array arithmetic') -----
eToysEQ: other
| result |
result _ ByteArray new: self size.
other isNumber ifTrue: [
^ self primEQScalar: self and: other into: result.
].
other isCollection ifTrue: [
^ self primEQArray: self and: other into: result.
].
^ super = other.
!
----- Method: WordArray>>eToysGE: (in category 'array arithmetic') -----
eToysGE: other
| result |
result _ ByteArray new: self size.
other isNumber ifTrue: [
^ self primGEScalar: self and: other into: result.
].
other isCollection ifTrue: [
^ self primGEArray: self and: other into: result.
].
^ super >= other.
!
----- Method: WordArray>>eToysGT: (in category 'array arithmetic') -----
eToysGT: other
| result |
result _ ByteArray new: self size.
other isNumber ifTrue: [
^ self primGTScalar: self and: other into: result.
].
other isCollection ifTrue: [
^ self primGTArray: self and: other into: result.
].
^ super > other.
!
----- Method: WordArray>>eToysLE: (in category 'array arithmetic') -----
eToysLE: other
| result |
result _ ByteArray new: self size.
other isNumber ifTrue: [
^ self primLEScalar: self and: other into: result.
].
other isCollection ifTrue: [
^ self primLEArray: self and: other into: result.
].
^ super <= other.
!
----- Method: WordArray>>eToysLT: (in category 'array arithmetic') -----
eToysLT: other
| result |
result _ ByteArray new: self size.
other isNumber ifTrue: [
^ self primLTScalar: self and: other into: result.
].
other isCollection ifTrue: [
^ self primLTArray: self and: other into: result.
].
^ super < other.
!
----- Method: WordArray>>eToysNE: (in category 'array arithmetic') -----
eToysNE: other
| result |
result _ ByteArray new: self size.
other isNumber ifTrue: [
^ self primNEScalar: self and: other into: result.
].
other isCollection ifTrue: [
^ self primNEArray: self and: other into: result.
].
^ super ~= other.
!
----- Method: WordArray>>primEQArray:and:into: (in category 'array arithmetic primitives') -----
primEQArray: rcvr and: other into: result
<primitive: 'primitiveEQArrays' module:'KedamaPlugin2'>
"^ KedamaPlugin doPrimitive: #primitiveEQArrays."
1 to: rcvr size do: [:i |
result at: i put: ((rcvr at: i) = (other at: i) ifTrue: [1] ifFalse: [0]).
].
^ result.
!
----- Method: WordArray>>primEQScalar:and:into: (in category 'array arithmetic primitives') -----
primEQScalar: rcvr and: other into: result
<primitive: 'primitiveEQScalar' module:'KedamaPlugin2'>
"^ KedamaPlugin doPrimitive: #primitiveEQScalar."
1 to: rcvr size do: [:i |
result at: i put: ((rcvr at: i) = other ifTrue: [1] ifFalse: [0]).
].
^ result.
!
----- Method: WordArray>>primGEArray:and:into: (in category 'array arithmetic primitives') -----
primGEArray: rcvr and: other into: result
<primitive: 'primitiveGEArrays' module:'KedamaPlugin2'>
"^ KedamaPlugin doPrimitive: #primitiveGEArrays."
1 to: rcvr size do: [:i |
result at: i put: ((rcvr at: i) >= (other at: i) ifTrue: [1] ifFalse: [0]).
].
^ result.
!
----- Method: WordArray>>primGEScalar:and:into: (in category 'array arithmetic primitives') -----
primGEScalar: rcvr and: other into: result
<primitive: 'primitiveGEScalar' module:'KedamaPlugin2'>
"^ KedamaPlugin doPrimitive: #primitiveGEScalar."
1 to: rcvr size do: [:i |
result at: i put: ((rcvr at: i) >= other ifTrue: [1] ifFalse: [0]).
].
^ result.
!
----- Method: WordArray>>primGTArray:and:into: (in category 'array arithmetic primitives') -----
primGTArray: rcvr and: other into: result
<primitive: 'primitiveGTArrays' module:'KedamaPlugin2'>
"^ KedamaPlugin doPrimitive: #primitiveGTArrays."
1 to: rcvr size do: [:i |
result at: i put: ((rcvr at: i) > (other at: i) ifTrue: [1] ifFalse: [0]).
].
^ result.
!
----- Method: WordArray>>primGTScalar:and:into: (in category 'array arithmetic primitives') -----
primGTScalar: rcvr and: other into: result
<primitive: 'primitiveGTScalar' module:'KedamaPlugin2'>
"^ KedamaPlugin doPrimitive: #primitiveGTScalar."
1 to: rcvr size do: [:i |
result at: i put: ((rcvr at: i) > other ifTrue: [1] ifFalse: [0]).
].
^ result.
!
----- Method: WordArray>>primLEArray:and:into: (in category 'array arithmetic primitives') -----
primLEArray: rcvr and: other into: result
<primitive: 'primitiveLEArrays' module:'KedamaPlugin2'>
"^ KedamaPlugin doPrimitive: #primitiveLEArrays."
1 to: rcvr size do: [:i |
result at: i put: ((rcvr at: i) <= (other at: i) ifTrue: [1] ifFalse: [0]).
].
^ result.
!
----- Method: WordArray>>primLEScalar:and:into: (in category 'array arithmetic primitives') -----
primLEScalar: rcvr and: other into: result
<primitive: 'primitiveLEScalar' module:'KedamaPlugin2'>
"^ KedamaPlugin doPrimitive: #primitiveLEScalar."
1 to: rcvr size do: [:i |
result at: i put: ((rcvr at: i) <= other ifTrue: [1] ifFalse: [0]).
].
^ result.
!
----- Method: WordArray>>primLTArray:and:into: (in category 'array arithmetic primitives') -----
primLTArray: rcvr and: other into: result
<primitive: 'primitiveLTArrays' module:'KedamaPlugin2'>
"^ KedamaPlugin doPrimitive: #primitiveLTArrays."
1 to: rcvr size do: [:i |
result at: i put: ((rcvr at: i) < (other at: i) ifTrue: [1] ifFalse: [0]).
].
^ result.
!
----- Method: WordArray>>primLTScalar:and:into: (in category 'array arithmetic primitives') -----
primLTScalar: rcvr and: other into: result
<primitive: 'primitiveLTScalar' module:'KedamaPlugin2'>
"^ KedamaPlugin doPrimitive: #primitiveLTScalar."
1 to: rcvr size do: [:i |
result at: i put: ((rcvr at: i) < other ifTrue: [1] ifFalse: [0]).
].
^ result.
!
----- Method: WordArray>>primNEArray:and:into: (in category 'array arithmetic primitives') -----
primNEArray: rcvr and: other into: result
<primitive: 'primitiveNEArrays' module:'KedamaPlugin2'>
"^ KedamaPlugin doPrimitive: #primitiveNEArrays."
1 to: rcvr size do: [:i |
result at: i put: ((rcvr at: i) ~= (other at: i) ifTrue: [1] ifFalse: [0]).
].
^ result.
!
----- Method: WordArray>>primNEScalar:and:into: (in category 'array arithmetic primitives') -----
primNEScalar: rcvr and: other into: result
<primitive: 'primitiveNEScalar' module:'KedamaPlugin2'>
"^ KedamaPlugin doPrimitive: #primitiveNEScalar."
1 to: rcvr size do: [:i |
result at: i put: ((rcvr at: i) ~= other ifTrue: [1] ifFalse: [0]).
].
^ result.
!
----- Method: WordArray>>replaceFrom:to:with:startingAt: (in category 'private') -----
replaceFrom: start to: stop with: replacement startingAt: repStart
<primitive: 105>
^super replaceFrom: start to: stop with: replacement startingAt: repStart !
WordArray variableWordSubclass: #WordArrayForSegment
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Arrayed'!
----- Method: WordArrayForSegment>>restoreEndianness (in category 'as yet unclassified') -----
restoreEndianness
"This word object was just read in from a stream. Do not correct the Endianness because the load primitive will reverse bytes as needed."
"^ self"
!
----- Method: WordArrayForSegment>>writeOn: (in category 'as yet unclassified') -----
writeOn: aByteStream
"Write quickly and disregard the endianness of the words. Store the array of bits onto the argument, aStream. (leading byte ~= 16r80) identifies this as raw bits (uncompressed)."
aByteStream nextInt32Put: self size. "4 bytes"
aByteStream nextPutAll: self
!
SequenceableCollection subclass: #Heap
instanceVariableNames: 'array tally sortBlock'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Sequenceable'!
!Heap commentStamp: '<historical>' prior: 0!
Class Heap implements a special data structure commonly referred to as 'heap'. Heaps are more efficient than SortedCollections if:
a) Elements are only removed at the beginning
b) Elements are added with arbitrary sort order.
The sort time for a heap is O(n log n) in all cases.
Instance variables:
array <Array> the data repository
tally <Integer> the number of elements in the heap
sortBlock <Block|nil> a two-argument block defining the sort order,
or nil in which case the default sort order is
[:element1 :element2| element1 <= element2]!
----- Method: Heap class>>heapExample (in category 'examples') -----
heapExample "Heap heapExample"
"Create a sorted collection of numbers, remove the elements
sequentially and add new objects randomly.
Note: This is the kind of benchmark a heap is designed for."
| n rnd array time sorted |
n _ 5000. "# of elements to sort"
rnd _ Random new.
array _ (1 to: n) collect:[:i| rnd next].
"First, the heap version"
time _ Time millisecondsToRun:[
sorted _ Heap withAll: array.
1 to: n do:[:i|
sorted removeFirst.
sorted add: rnd next].
].
Transcript cr; show:'Time for Heap: ', time printString,' msecs'.
"The quicksort version"
time _ Time millisecondsToRun:[
sorted _ SortedCollection withAll: array.
1 to: n do:[:i|
sorted removeFirst.
sorted add: rnd next].
].
Transcript cr; show:'Time for SortedCollection: ', time printString,' msecs'.
!
----- Method: Heap class>>heapSortExample (in category 'examples') -----
heapSortExample "Heap heapSortExample"
"Sort a random collection of Floats and compare the results with
SortedCollection (using the quick-sort algorithm) and
ArrayedCollection>>mergeSortFrom:to:by: (using the merge-sort algorithm)."
| n rnd array out time sorted |
n _ 10000. "# of elements to sort"
rnd _ Random new.
array _ (1 to: n) collect:[:i| rnd next].
"First, the heap version"
out _ Array new: n. "This is where we sort into"
time _ Time millisecondsToRun:[
sorted _ Heap withAll: array.
1 to: n do:[:i| sorted removeFirst].
].
Transcript cr; show:'Time for heap-sort: ', time printString,' msecs'.
"The quicksort version"
time _ Time millisecondsToRun:[
sorted _ SortedCollection withAll: array.
].
Transcript cr; show:'Time for quick-sort: ', time printString,' msecs'.
"The merge-sort version"
time _ Time millisecondsToRun:[
array mergeSortFrom: 1 to: array size by: [:v1 :v2| v1 <= v2].
].
Transcript cr; show:'Time for merge-sort: ', time printString,' msecs'.
!
----- Method: Heap class>>new (in category 'instance creation') -----
new
^self new: 10!
----- Method: Heap class>>new: (in category 'instance creation') -----
new: n
^super new setCollection: (Array new: n)!
----- Method: Heap class>>sortBlock: (in category 'instance creation') -----
sortBlock: aBlock
"Create a new heap sorted by the given block"
^self new sortBlock: aBlock!
----- Method: Heap class>>withAll: (in category 'instance creation') -----
withAll: aCollection
"Create a new heap with all the elements from aCollection"
^(self basicNew)
setCollection: aCollection asArray copy tally: aCollection size;
reSort;
yourself!
----- Method: Heap class>>withAll:sortBlock: (in category 'instance creation') -----
withAll: aCollection sortBlock: sortBlock
"Create a new heap with all the elements from aCollection"
^(self basicNew)
setCollection: aCollection asArray copy tally: aCollection size;
sortBlock: sortBlock;
yourself!
----- Method: Heap>>= (in category 'comparing') -----
= anObject
^ self == anObject
ifTrue: [true]
ifFalse: [anObject isHeap
ifTrue: [sortBlock = anObject sortBlock and: [super = anObject]]
ifFalse: [super = anObject]]!
----- Method: Heap>>add: (in category 'adding') -----
add: anObject
"Include newObject as one of the receiver's elements. Answer newObject."
tally = array size ifTrue:[self grow].
array at: (tally _ tally + 1) put: anObject.
self upHeap: tally.
^anObject!
----- Method: Heap>>array (in category 'private') -----
array
^array!
----- Method: Heap>>at: (in category 'accessing') -----
at: index
"Return the element at the given position within the receiver"
(index < 1 or:[index > tally]) ifTrue:[^self errorSubscriptBounds: index].
^array at: index!
----- Method: Heap>>at:put: (in category 'accessing') -----
at: index put: newObject
"Heaps are accessed with #add: not #at:put:"
^self shouldNotImplement!
----- Method: Heap>>do: (in category 'enumerating') -----
do: aBlock
"Evaluate aBlock with each of the receiver's elements as the argument."
1 to: tally do:[:i| aBlock value: (array at: i)]!
----- Method: Heap>>downHeap: (in category 'private-heap') -----
downHeap: anIndex
"Check the heap downwards for correctness starting at anIndex.
Everything above (i.e. left of) anIndex is ok."
| value k n j |
anIndex = 0 ifTrue:[^self].
n _ tally bitShift: -1.
k _ anIndex.
value _ array at: anIndex.
[k <= n] whileTrue:[
j _ k + k.
"use max(j,j+1)"
(j < tally and:[self sorts: (array at: j+1) before: (array at: j)])
ifTrue:[ j _ j + 1].
"check if position k is ok"
(self sorts: value before: (array at: j))
ifTrue:[ "yes -> break loop"
n _ k - 1]
ifFalse:[ "no -> make room at j by moving j-th element to k-th position"
array at: k put: (array at: j).
"and try again with j"
k _ j]].
array at: k put: value.!
----- Method: Heap>>downHeapSingle: (in category 'private-heap') -----
downHeapSingle: anIndex
"This version is optimized for the case when only one element in the receiver can be at a wrong position. It avoids one comparison at each node when travelling down the heap and checks the heap upwards after the element is at a bottom position. Since the probability for being at the bottom of the heap is much larger than for being somewhere in the middle this version should be faster."
| value k n j |
anIndex = 0 ifTrue:[^self].
n _ tally bitShift: -1.
k _ anIndex.
value _ array at: anIndex.
[k <= n] whileTrue:[
j _ k + k.
"use max(j,j+1)"
(j < tally and:[self sorts: (array at: j+1) before: (array at: j)])
ifTrue:[ j _ j + 1].
array at: k put: (array at: j).
"and try again with j"
k _ j].
array at: k put: value.
self upHeap: k!
----- Method: Heap>>first (in category 'accessing') -----
first
"Return the first element in the receiver"
self emptyCheck.
^array at: 1!
----- Method: Heap>>grow (in category 'growing') -----
grow
"Become larger."
self growTo: self size + self growSize.!
----- Method: Heap>>growSize (in category 'growing') -----
growSize
"Return the size by which the receiver should grow if there are no empty slots left."
^array size max: 5!
----- Method: Heap>>growTo: (in category 'growing') -----
growTo: newSize
"Grow to the requested size."
| newArray |
newArray _ Array new: (newSize max: tally).
newArray replaceFrom: 1 to: array size with: array startingAt: 1.
array _ newArray!
----- Method: Heap>>isEmpty (in category 'testing') -----
isEmpty
"Answer whether the receiver contains any elements."
^tally = 0!
----- Method: Heap>>isHeap (in category 'testing') -----
isHeap
^ true!
----- Method: Heap>>privateRemoveAt: (in category 'private') -----
privateRemoveAt: index
"Remove the element at the given index and make sure the sorting order is okay"
| removed |
removed _ array at: index.
array at: index put: (array at: tally).
array at: tally put: nil.
tally _ tally - 1.
index > tally ifFalse:[
"Use #downHeapSingle: since only one element has been removed"
self downHeapSingle: index].
^removed!
----- Method: Heap>>reSort (in category 'accessing') -----
reSort
"Resort the entire heap"
self isEmpty ifTrue:[^self].
tally // 2 to: 1 by: -1 do:[:i| self downHeap: i].!
----- Method: Heap>>remove:ifAbsent: (in category 'removing') -----
remove: oldObject ifAbsent: aBlock
"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."
1 to: tally do:[:i|
(array at: i) = oldObject ifTrue:[^self privateRemoveAt: i]].
^aBlock value!
----- Method: Heap>>removeAt: (in category 'removing') -----
removeAt: index
"Remove the element at given position"
(index < 1 or:[index > tally]) ifTrue:[^self errorSubscriptBounds: index].
^self privateRemoveAt: index!
----- Method: Heap>>removeFirst (in category 'removing') -----
removeFirst
"Remove the first element from the receiver"
^self removeAt: 1!
----- Method: Heap>>setCollection: (in category 'private') -----
setCollection: aCollection
array _ aCollection.
tally _ 0.!
----- Method: Heap>>setCollection:tally: (in category 'private') -----
setCollection: aCollection tally: newTally
array _ aCollection.
tally _ newTally.!
----- Method: Heap>>size (in category 'accessing') -----
size
"Answer how many elements the receiver contains."
^ tally!
----- Method: Heap>>sortBlock (in category 'accessing') -----
sortBlock
^sortBlock!
----- Method: Heap>>sortBlock: (in category 'accessing') -----
sortBlock: aBlock
sortBlock _ aBlock.
sortBlock fixTemps.
self reSort.!
----- Method: Heap>>sorts:before: (in category 'testing') -----
sorts: element1 before: element2
"Return true if element1 should be sorted before element2.
This method defines the sort order in the receiver"
^sortBlock == nil
ifTrue:[element1 <= element2]
ifFalse:[sortBlock value: element1 value: element2].!
----- Method: Heap>>species (in category 'private') -----
species
^ Array!
----- Method: Heap>>trim (in category 'growing') -----
trim
"Remove any empty slots in the receiver."
self growTo: self size.!
----- Method: Heap>>upHeap: (in category 'private-heap') -----
upHeap: anIndex
"Check the heap upwards for correctness starting at anIndex.
Everything below anIndex is ok."
| value k kDiv2 tmp |
anIndex = 0 ifTrue:[^self].
k _ anIndex.
value _ array at: anIndex.
[ (k > 1) and:[self sorts: value before: (tmp _ array at: (kDiv2 _ k bitShift: -1))] ]
whileTrue:[
array at: k put: tmp.
k _ kDiv2].
array at: k put: value.!
SequenceableCollection subclass: #Interval
instanceVariableNames: 'start stop step'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Sequenceable'!
!Interval commentStamp: '<historical>' prior: 0!
I represent a finite arithmetic progression.!
----- Method: Interval class>>from:to: (in category 'instance creation') -----
from: startInteger to: stopInteger
"Answer an instance of me, starting at startNumber, ending at
stopNumber, and with an interval increment of 1."
^self new
setFrom: startInteger
to: stopInteger
by: 1!
----- Method: Interval class>>from:to:by: (in category 'instance creation') -----
from: startInteger to: stopInteger by: stepInteger
"Answer an instance of me, starting at startNumber, ending at
stopNumber, and with an interval increment of stepNumber."
^self new
setFrom: startInteger
to: stopInteger
by: stepInteger!
----- Method: Interval class>>new (in category 'instance creation') -----
new
"Primitive. Create and answer with a new instance of the receiver
(a class) with no indexable fields. Fail if the class is indexable. Override
SequenceableCollection new. Essential. See Object documentation
whatIsAPrimitive."
<primitive: 70>
self isVariable ifTrue: [ ^ self new: 0 ].
"space must be low"
Smalltalk signalLowSpace.
^ self new "retry if user proceeds"
!
----- Method: Interval class>>newFrom: (in category 'instance creation') -----
newFrom: aCollection
"Answer an instance of me containing the same elements as aCollection."
| newInterval n |
(n := aCollection size) <= 1 ifTrue: [
n = 0 ifTrue: [^self from: 1 to: 0].
^self from: aCollection first to: aCollection last].
newInterval := self from: aCollection first to: aCollection last
by: (aCollection last - aCollection first) // (n - 1).
aCollection ~= newInterval
ifTrue: [self error: 'The argument is not an arithmetic progression'].
^newInterval
" Interval newFrom: {1. 2. 3}
{33. 5. -23} as: Interval
{33. 5. -22} as: Interval (an error)
(-4 to: -12 by: -1) as: Interval
"!
----- Method: Interval>>+ (in category 'arithmetic') -----
+ number
^ start + number to: stop + number by: step!
----- Method: Interval>>- (in category 'arithmetic') -----
- number
^ start - number to: stop - number by: step!
----- Method: Interval>>= (in category 'comparing') -----
= anObject
^ self == anObject
ifTrue: [true]
ifFalse: [anObject isInterval
ifTrue: [start = anObject first
and: [step = anObject increment
and: [self last = anObject last]]]
ifFalse: [super = anObject]]!
----- Method: Interval>>add: (in category 'adding') -----
add: newObject
"Adding to an Interval is not allowed."
self shouldNotImplement!
----- Method: Interval>>at: (in category 'accessing') -----
at: anInteger
"Answer the anInteger'th element."
(anInteger >= 1 and: [anInteger <= self size])
ifTrue: [^start + (step * (anInteger - 1))]
ifFalse: [self errorSubscriptBounds: anInteger]!
----- Method: Interval>>at:put: (in category 'accessing') -----
at: anInteger put: anObject
"Storing into an Interval is not allowed."
self error: 'you can not store into an interval'!
----- Method: Interval>>collect: (in category 'enumerating') -----
collect: aBlock
| nextValue result |
result _ self species new: self size.
nextValue _ start.
1 to: result size do:
[:i |
result at: i put: (aBlock value: nextValue).
nextValue _ nextValue + step].
^ result!
----- Method: Interval>>copy (in category 'copying') -----
copy
"Return a copy of me. Override the superclass because my species is
Array and copy, as inherited from SequenceableCollection, uses
copyFrom:to:, which creates a new object of my species."
^self shallowCopy!
----- Method: Interval>>do: (in category 'enumerating') -----
do: aBlock
| aValue |
aValue _ start.
step < 0
ifTrue: [[stop <= aValue]
whileTrue:
[aBlock value: aValue.
aValue _ aValue + step]]
ifFalse: [[stop >= aValue]
whileTrue:
[aBlock value: aValue.
aValue _ aValue + step]]!
----- Method: Interval>>extent (in category 'accessing') -----
extent
"Answer the max - min of the receiver interval."
"(10 to: 50) extent"
^stop - start!
----- Method: Interval>>first (in category 'accessing') -----
first
"Refer to the comment in SequenceableCollection|first."
^start!
----- Method: Interval>>hash (in category 'comparing') -----
hash
"Hash is reimplemented because = is implemented."
^(((start hash bitShift: 2)
bitOr: stop hash)
bitShift: 1)
bitOr: self size!
----- Method: Interval>>hashMappedBy: (in category 'comparing') -----
hashMappedBy: map
"My hash is independent of my oop."
^self hash!
----- Method: Interval>>includes: (in category 'nil') -----
includes: aNumber
^ aNumber between: self first and: self last!
----- Method: Interval>>increment (in category 'accessing') -----
increment
"Answer the receiver's interval increment."
^step!
----- Method: Interval>>isInterval (in category 'testing') -----
isInterval
^ true!
----- Method: Interval>>last (in category 'accessing') -----
last
"Refer to the comment in SequenceableCollection|last."
^stop - (stop - start \\ step)!
----- Method: Interval>>permutationsDo: (in category 'enumerating') -----
permutationsDo: aBlock
"Repeatly value aBlock with a single copy of the receiver. Reorder the copy
so that aBlock is presented all (self size factorial) possible permutations."
"(1 to: 4) permutationsDo: [:each | Transcript cr; show: each printString]"
self asArray permutationsDo: aBlock
!
----- Method: Interval>>printOn: (in category 'printing') -----
printOn: aStream
aStream nextPut: $(;
print: start;
nextPutAll: ' to: ';
print: stop.
step ~= 1 ifTrue: [aStream nextPutAll: ' by: '; print: step].
aStream nextPut: $)!
----- Method: Interval>>rangeIncludes: (in category 'accessing') -----
rangeIncludes: aNumber
"Return true if the number lies in the interval between start and stop."
step >= 0
ifTrue: [^ aNumber between: start and: stop]
ifFalse: [^ aNumber between: stop and: start]
!
----- Method: Interval>>remove: (in category 'removing') -----
remove: newObject
"Removing from an Interval is not allowed."
self error: 'elements cannot be removed from an Interval'!
----- Method: Interval>>reverseDo: (in category 'enumerating') -----
reverseDo: aBlock
"Evaluate aBlock for each element of my interval, in reverse order."
| aValue |
aValue _ stop.
step < 0
ifTrue: [[start >= aValue]
whileTrue:
[aBlock value: aValue.
aValue _ aValue - step]]
ifFalse: [[start <= aValue]
whileTrue:
[aBlock value: aValue.
aValue _ aValue - step]]!
----- Method: Interval>>setFrom:to:by: (in category 'private') -----
setFrom: startInteger to: stopInteger by: stepInteger
start _ startInteger.
stop _ stopInteger.
step _ stepInteger!
----- Method: Interval>>shallowCopy (in category 'copying') -----
shallowCopy
"Without this method, #copy would return an array instead of a new interval.
The whole problem is burried in the class hierarchy and every fix will worsen
the problem, so once the whole issue is resolved one should come back to this
method fix it."
^ self class from: start to: stop by: step!
----- Method: Interval>>size (in category 'accessing') -----
size
"Answer how many elements the receiver contains."
step < 0
ifTrue: [start < stop
ifTrue: [^ 0]
ifFalse: [^ stop - start // step + 1]]
ifFalse: [stop < start
ifTrue: [^ 0]
ifFalse: [^ stop - start // step + 1]]!
----- Method: Interval>>species (in category 'private') -----
species
^Array!
----- Method: Interval>>start (in category 'accessing') -----
start
^ start!
----- Method: Interval>>stop (in category 'accessing') -----
stop
^ stop!
----- Method: Interval>>storeOn: (in category 'printing') -----
storeOn: aStream
"This is possible because we know numbers store and print the same."
self printOn: aStream!
----- Method: Interval>>valuesInclude: (in category 'private') -----
valuesInclude: aNumber
"Private - answer whether or not aNumber is one of the enumerated values in this interval."
| val |
val _ (aNumber - self first) asFloat / self increment.
^ val fractionPart abs < (step * 1.0e-10)!
SequenceableCollection subclass: #LinkedList
instanceVariableNames: 'firstLink lastLink'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Sequenceable'!
!LinkedList commentStamp: '<historical>' prior: 0!
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.!
----- Method: LinkedList>>add: (in category 'adding') -----
add: aLink
"Add aLink to the end of the receiver's list. Answer aLink."
^self addLast: aLink!
----- Method: LinkedList>>add:after: (in category 'adding') -----
add: link after: otherLink
"Add otherLink after link in the list. Answer aLink."
| savedLink |
savedLink := otherLink nextLink.
otherLink nextLink: link.
link nextLink: savedLink.
^link.!
----- Method: LinkedList>>add:before: (in category 'adding') -----
add: link before: otherLink
| aLink |
firstLink == otherLink ifTrue: [^ self addFirst: link].
aLink _ firstLink.
[aLink == nil] whileFalse: [
aLink nextLink == otherLink ifTrue: [
link nextLink: aLink nextLink.
aLink nextLink: link.
^ link
].
aLink _ aLink nextLink.
].
^ self errorNotFound: otherLink!
----- Method: LinkedList>>addFirst: (in category 'adding') -----
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!
----- Method: LinkedList>>addLast: (in category 'adding') -----
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!
----- Method: LinkedList>>at: (in category 'accessing') -----
at: index
| i |
i _ 0.
self do: [:link |
(i _ i + 1) = index ifTrue: [^ link]].
^ self errorSubscriptBounds: index!
----- Method: LinkedList>>do: (in category 'enumerating') -----
do: aBlock
| aLink |
aLink _ firstLink.
[aLink == nil] whileFalse:
[aBlock value: aLink.
aLink _ aLink nextLink]!
----- Method: LinkedList>>first (in category 'accessing') -----
first
"Answer the first link. Create an error notification if the receiver is
empty."
self emptyCheck.
^firstLink!
----- Method: LinkedList>>isEmpty (in category 'testing') -----
isEmpty
^firstLink == nil!
----- Method: LinkedList>>last (in category 'accessing') -----
last
"Answer the last link. Create an error notification if the receiver is
empty."
self emptyCheck.
^lastLink!
----- Method: LinkedList>>remove:ifAbsent: (in category '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!
----- Method: LinkedList>>removeFirst (in category 'removing') -----
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!
----- Method: LinkedList>>removeLast (in category 'removing') -----
removeLast
"Remove the receiver's last element and answer it. If the receiver is
empty, create an error notification."
| oldLink aLink |
self emptyCheck.
oldLink _ lastLink.
firstLink == lastLink
ifTrue: [firstLink _ nil. lastLink _ nil]
ifFalse: [aLink _ firstLink.
[aLink nextLink == oldLink] whileFalse:
[aLink _ aLink nextLink].
aLink nextLink: nil.
lastLink _ aLink].
oldLink nextLink: nil.
^oldLink!
----- Method: LinkedList>>species (in category 'enumerating') -----
species
^ Array!
SequenceableCollection subclass: #OrderedCollection
instanceVariableNames: 'array firstIndex lastIndex'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Sequenceable'!
!OrderedCollection commentStamp: '<historical>' prior: 0!
I represent a collection of objects ordered by the collector.!
----- Method: OrderedCollection class>>new (in category 'instance creation') -----
new
^ self new: 10!
----- Method: OrderedCollection class>>new: (in category 'instance creation') -----
new: anInteger
^ super basicNew setCollection: (Array new: anInteger)!
----- Method: OrderedCollection class>>newFrom: (in category 'instance creation') -----
newFrom: aCollection
"Answer an instance of me containing the same elements as aCollection."
| newCollection |
newCollection _ self new: aCollection size.
newCollection addAll: aCollection.
^newCollection
" OrderedCollection newFrom: {1. 2. 3}
{1. 2. 3} as: OrderedCollection
{4. 2. 7} as: SortedCollection
"!
----- Method: OrderedCollection class>>ofSize: (in category 'instance creation') -----
ofSize: n
"Create a new collection of size n with nil as its elements.
This method exists because OrderedCollection new: n creates an
empty collection, not one of size n."
| collection |
collection _ self new: n.
collection setContents: (collection collector).
^ collection
!
----- Method: OrderedCollection>>add: (in category 'adding') -----
add: newObject
^self addLast: newObject!
----- Method: OrderedCollection>>add:after: (in category 'adding') -----
add: newObject after: oldObject
"Add the argument, newObject, as an element of the receiver. Put it in
the sequence just succeeding oldObject. Answer newObject."
| index |
index _ self find: oldObject.
self insert: newObject before: index + 1.
^newObject!
----- Method: OrderedCollection>>add:afterIndex: (in category 'adding') -----
add: newObject afterIndex: index
"Add the argument, newObject, as an element of the receiver. Put it in
the sequence just after index. Answer newObject."
self insert: newObject before: firstIndex + index.
^ newObject!
----- Method: OrderedCollection>>add:before: (in category 'adding') -----
add: newObject before: oldObject
"Add the argument, newObject, as an element of the receiver. Put it in
the sequence just preceding oldObject. Answer newObject."
| index |
index _ self find: oldObject.
self insert: newObject before: index.
^newObject!
----- Method: OrderedCollection>>add:beforeIndex: (in category 'adding') -----
add: newObject beforeIndex: index
"Add the argument, newObject, as an element of the receiver. Put it in
the sequence just before index. Answer newObject."
self add: newObject afterIndex: index - 1.
^ newObject!
----- Method: OrderedCollection>>addAll: (in category 'adding') -----
addAll: aCollection
"Add each element of aCollection at my end. Answer aCollection."
^ self addAllLast: aCollection!
----- Method: OrderedCollection>>addAllFirst: (in category 'adding') -----
addAllFirst: anOrderedCollection
"Add each element of anOrderedCollection at the beginning of the
receiver. Answer anOrderedCollection."
anOrderedCollection reverseDo: [:each | self addFirst: each].
^anOrderedCollection!
----- Method: OrderedCollection>>addAllFirstUnlessAlreadyPresent: (in category 'adding') -----
addAllFirstUnlessAlreadyPresent: anOrderedCollection
"Add each element of anOrderedCollection at the beginning of the receiver, preserving the order, but do not add any items that are already in the receiver. Answer anOrderedCollection."
anOrderedCollection reverseDo:
[:each | (self includes: each) ifFalse: [self addFirst: each]].
^ anOrderedCollection!
----- Method: OrderedCollection>>addAllLast: (in category 'adding') -----
addAllLast: anOrderedCollection
"Add each element of anOrderedCollection at the end of the receiver.
Answer anOrderedCollection."
anOrderedCollection do: [:each | self addLast: each].
^anOrderedCollection!
----- Method: OrderedCollection>>addFirst: (in category 'adding') -----
addFirst: newObject
"Add newObject to the beginning of the receiver. Answer newObject."
firstIndex = 1 ifTrue: [self makeRoomAtFirst].
firstIndex _ firstIndex - 1.
array at: firstIndex put: newObject.
^ newObject!
----- Method: OrderedCollection>>addLast: (in category 'adding') -----
addLast: newObject
"Add newObject to the end of the receiver. Answer newObject."
lastIndex = array size ifTrue: [self makeRoomAtLast].
lastIndex _ lastIndex + 1.
array at: lastIndex put: newObject.
^ newObject!
----- Method: OrderedCollection>>at: (in category 'accessing') -----
at: anInteger
"Answer my element at index anInteger. at: is used by a knowledgeable
client to access an existing element"
(anInteger < 1 or: [anInteger + firstIndex - 1 > lastIndex])
ifTrue: [self errorNoSuchElement]
ifFalse: [^ array at: anInteger + firstIndex - 1]!
----- Method: OrderedCollection>>at:ifAbsentPut: (in category 'adding') -----
at: index ifAbsentPut: block
"Return value at index, however, if value does not exist (nil or out of bounds) then add block's value at index (growing self if necessary)"
| v |
index <= self size ifTrue: [
^ (v _ self at: index)
ifNotNil: [v]
ifNil: [self at: index put: block value]
].
[self size < index] whileTrue: [self add: nil].
^ self at: index put: block value!
----- Method: OrderedCollection>>at:put: (in category 'accessing') -----
at: anInteger put: anObject
"Put anObject at element index anInteger. at:put: cannot be used to
append, front or back, to an ordered collection; it is used by a
knowledgeable client to replace an element."
| index |
index _ anInteger asInteger.
(index < 1 or: [index + firstIndex - 1 > lastIndex])
ifTrue: [self errorNoSuchElement]
ifFalse: [^array at: index + firstIndex - 1 put: anObject]!
----- Method: OrderedCollection>>capacity (in category 'accessing') -----
capacity
"Answer the current capacity of the receiver."
^ array size!
----- Method: OrderedCollection>>collect: (in category 'enumerating') -----
collect: aBlock
"Evaluate aBlock with each of my elements as the argument. Collect the
resulting values into a collection that is like me. Answer the new
collection. Override superclass in order to use addLast:, not at:put:."
| newCollection |
newCollection _ self species new: self size.
firstIndex to: lastIndex do:
[:index |
newCollection addLast: (aBlock value: (array at: index))].
^ newCollection!
----- Method: OrderedCollection>>collect:from:to: (in category 'enumerating') -----
collect: aBlock from: fromIndex to: toIndex
"Override superclass in order to use addLast:, not at:put:."
| result |
(fromIndex < 1 or:[toIndex + firstIndex - 1 > lastIndex])
ifTrue: [^self errorNoSuchElement].
result _ self species new: toIndex - fromIndex + 1.
firstIndex + fromIndex - 1 to: firstIndex + toIndex - 1 do:
[:index | result addLast: (aBlock value: (array at: index))].
^ result
!
----- Method: OrderedCollection>>collector (in category 'private') -----
collector "Private"
^ array!
----- Method: OrderedCollection>>copyEmpty (in category 'copying') -----
copyEmpty
"Answer a copy of the receiver that contains no elements."
^self species new!
----- Method: OrderedCollection>>copyFrom:to: (in category 'copying') -----
copyFrom: startIndex to: endIndex
"Answer a copy of the receiver that contains elements from position
startIndex to endIndex."
| targetCollection |
endIndex < startIndex ifTrue: [^self species new: 0].
targetCollection _ self species new: endIndex + 1 - startIndex.
startIndex to: endIndex do: [:index | targetCollection addLast: (self at: index)].
^ targetCollection!
----- Method: OrderedCollection>>copyReplaceFrom:to:with: (in category 'copying') -----
copyReplaceFrom: start to: stop with: replacementCollection
"Answer a copy of the receiver with replacementCollection's elements in
place of the receiver's start'th to stop'th elements. This does not expect
a 1-1 map from replacementCollection to the start to stop elements, so it
will do an insert or append."
| newOrderedCollection delta startIndex stopIndex |
"if start is less than 1, ignore stop and assume this is inserting at the front.
if start greater than self size, ignore stop and assume this is appending.
otherwise, it is replacing part of me and start and stop have to be within my
bounds. "
delta _ 0.
startIndex _ start.
stopIndex _ stop.
start < 1
ifTrue: [startIndex _ stopIndex _ 0]
ifFalse: [startIndex > self size
ifTrue: [startIndex _ stopIndex _ self size + 1]
ifFalse:
[(stopIndex < (startIndex - 1) or: [stopIndex > self size])
ifTrue: [self errorOutOfBounds].
delta _ stopIndex - startIndex + 1]].
newOrderedCollection _
self species new: self size + replacementCollection size - delta.
1 to: startIndex - 1 do: [:index | newOrderedCollection add: (self at: index)].
1 to: replacementCollection size do:
[:index | newOrderedCollection add: (replacementCollection at: index)].
stopIndex + 1 to: self size do: [:index | newOrderedCollection add: (self at: index)].
^newOrderedCollection!
----- Method: OrderedCollection>>copyWith: (in category 'copying') -----
copyWith: newElement
"Answer a copy of the receiver that is 1 bigger than the receiver and
includes the argument, newElement, at the end."
| newCollection |
newCollection _ self copy.
newCollection add: newElement.
^newCollection!
----- Method: OrderedCollection>>do: (in category 'enumerating') -----
do: aBlock
"Override the superclass for performance reasons."
| index |
index _ firstIndex.
[index <= lastIndex]
whileTrue:
[aBlock value: (array at: index).
index _ index + 1]!
----- Method: OrderedCollection>>errorConditionNotSatisfied (in category 'private') -----
errorConditionNotSatisfied
self error: 'no element satisfies condition'!
----- Method: OrderedCollection>>errorNoSuchElement (in category 'private') -----
errorNoSuchElement
self error: 'attempt to index non-existent element in an ordered collection'!
----- Method: OrderedCollection>>find: (in category 'private') -----
find: oldObject
" This method answers an index in the range firstIndex .. lastIndex, which is meant for internal use only.
Never use this method in your code, the methods for public use are:
#indexOf:
#indexOf:ifAbsent: "
| index |
index _ firstIndex.
[index <= lastIndex]
whileTrue:
[(array at: index) = oldObject ifTrue: [^ index].
index _ index + 1].
self errorNotFound: oldObject!
----- Method: OrderedCollection>>grow (in category 'adding') -----
grow
"Become larger. Typically, a subclass has to override this if the subclass
adds instance variables."
| newArray |
newArray _ Array new: self size + self growSize.
newArray replaceFrom: 1 to: array size with: array startingAt: 1.
array _ newArray!
----- Method: OrderedCollection>>growSize (in category 'adding') -----
growSize
^ array size max: 2!
----- Method: OrderedCollection>>insert:before: (in category 'private') -----
insert: anObject before: spot
" spot is an index in the range firstIndex .. lastIndex, such an index is not known from outside the collection.
Never use this method in your code, it is meant for private use by OrderedCollection only.
The methods for use are:
#add:before: to insert an object before another object
#add:beforeIndex: to insert an object before a given position. "
| "index" delta spotIndex|
spotIndex _ spot.
delta _ spotIndex - firstIndex.
firstIndex = 1
ifTrue:
[self makeRoomAtFirst.
spotIndex _ firstIndex + delta].
firstIndex _ firstIndex - 1.
array
replaceFrom: firstIndex
to: spotIndex - 2
with: array
startingAt: firstIndex + 1.
array at: spotIndex - 1 put: anObject.
" index _ firstIndex _ firstIndex - 1.
[index < (spotIndex - 1)]
whileTrue:
[array at: index put: (array at: index + 1).
index _ index + 1].
array at: index put: anObject."
^ anObject!
----- Method: OrderedCollection>>makeRoomAtFirst (in category 'private') -----
makeRoomAtFirst
| delta index |
delta _ array size - self size.
delta = 0 ifTrue:
[self grow.
delta _ array size - self size].
lastIndex = array size ifTrue: [^ self]. "just in case we got lucky"
index _ array size.
[index > delta]
whileTrue:
[array at: index put: (array at: index - delta + firstIndex - 1).
array at: index - delta + firstIndex - 1 put: nil.
index _ index - 1].
firstIndex _ delta + 1.
lastIndex _ array size!
----- Method: OrderedCollection>>makeRoomAtLast (in category 'private') -----
makeRoomAtLast
| newLast delta |
newLast _ self size.
array size - self size = 0 ifTrue: [self grow].
(delta _ firstIndex - 1) = 0 ifTrue: [^ self].
"we might be here under false premises or grow did the job for us"
1 to: newLast do:
[:index |
array at: index put: (array at: index + delta).
array at: index + delta put: nil].
firstIndex _ 1.
lastIndex _ newLast!
----- Method: OrderedCollection>>remove:ifAbsent: (in category 'removing') -----
remove: oldObject ifAbsent: absentBlock
| index |
index _ firstIndex.
[index <= lastIndex]
whileTrue:
[oldObject = (array at: index)
ifTrue:
[self removeIndex: index.
^ oldObject]
ifFalse: [index _ index + 1]].
^ absentBlock value!
----- Method: OrderedCollection>>removeAllSuchThat: (in category 'removing') -----
removeAllSuchThat: aBlock
"Remove each element of the receiver for which aBlock evaluates to true.
The method in Collection is O(N^2), this is O(N)."
| n |
n _ firstIndex.
firstIndex to: lastIndex do: [:index |
(aBlock value: (array at: index)) ifFalse: [
array at: n put: (array at: index).
n _ n + 1]].
n to: lastIndex do: [:index | array at: index put: nil].
lastIndex _ n - 1!
----- Method: OrderedCollection>>removeAt: (in category 'removing') -----
removeAt: index
| removed |
removed _ self at: index.
self removeIndex: index + firstIndex - 1.
^removed!
----- Method: OrderedCollection>>removeFirst (in category 'removing') -----
removeFirst
"Remove the first element of the receiver and answer it. If the receiver is
empty, create an error notification."
| firstObject |
self emptyCheck.
firstObject _ array at: firstIndex.
array at: firstIndex put: nil.
firstIndex _ firstIndex + 1.
^ firstObject!
----- Method: OrderedCollection>>removeFirst: (in category 'removing') -----
removeFirst: n
"Remove first n object into an array"
| list |
list _ Array new: n.
1 to: n do: [:i |
list at: i put: self removeFirst].
^ list!
----- Method: OrderedCollection>>removeIndex: (in category 'private') -----
removeIndex: removedIndex
" removedIndex is an index in the range firstIndex .. lastIndex, such an index is not known from outside the collection.
Never use this method in your code, it is meant for private use by OrderedCollection only.
The method for public use is:
#removeAt: "
array
replaceFrom: removedIndex
to: lastIndex - 1
with: array
startingAt: removedIndex+1.
array at: lastIndex put: nil.
lastIndex _ lastIndex - 1.!
----- Method: OrderedCollection>>removeLast (in category 'removing') -----
removeLast
"Remove the last element of the receiver and answer it. If the receiver is
empty, create an error notification."
| lastObject |
self emptyCheck.
lastObject _ array at: lastIndex.
array at: lastIndex put: nil.
lastIndex _ lastIndex - 1.
^ lastObject!
----- Method: OrderedCollection>>removeLast: (in category 'removing') -----
removeLast: n
"Remove last n object into an array with last in last position"
| list |
list _ Array new: n.
n to: 1 by: -1 do: [:i |
list at: i put: self removeLast].
^ list!
----- Method: OrderedCollection>>reset (in category 'private') -----
reset
firstIndex _ array size // 3 max: 1.
lastIndex _ firstIndex - 1!
----- Method: OrderedCollection>>resetTo: (in category 'private') -----
resetTo: index
firstIndex _ index.
lastIndex _ firstIndex - 1!
----- Method: OrderedCollection>>reverseDo: (in category 'enumerating') -----
reverseDo: aBlock
"Override the superclass for performance reasons."
| index |
index _ lastIndex.
[index >= firstIndex]
whileTrue:
[aBlock value: (array at: index).
index _ index - 1]!
----- Method: OrderedCollection>>reversed (in category 'copying') -----
reversed
"Answer a copy of the receiver with element order reversed. "
| newCol |
newCol _ self species new.
self reverseDo:
[:elem | newCol addLast: elem].
^ newCol
"#(2 3 4 'fred') reversed"!
----- Method: OrderedCollection>>select: (in category 'enumerating') -----
select: aBlock
"Evaluate aBlock with each of my elements as the argument. Collect into
a new collection like the receiver, only those elements for which aBlock
evaluates to true."
| newCollection element |
newCollection _ self copyEmpty.
firstIndex to: lastIndex do:
[:index |
(aBlock value: (element _ array at: index))
ifTrue: [newCollection addLast: element]].
^ newCollection!
----- Method: OrderedCollection>>setCollection: (in category 'private') -----
setCollection: anArray
array _ anArray.
self reset!
----- Method: OrderedCollection>>setContents: (in category 'private') -----
setContents: anArray
array _ anArray.
firstIndex _ 1.
lastIndex _ array size.!
----- Method: OrderedCollection>>size (in category 'accessing') -----
size
"Answer how many elements the receiver contains."
^ lastIndex - firstIndex + 1!
----- Method: OrderedCollection>>sort: (in category 'sorting') -----
sort: aSortBlock
"Sort this collection using aSortBlock. The block should take two arguments
and return true if the first element should preceed the second one.
If aSortBlock is nil then <= is used for comparison."
self ifNotEmpty: [
array
mergeSortFrom: firstIndex
to: lastIndex
by: aSortBlock ]!
----- Method: OrderedCollection>>with:collect: (in category 'enumerating') -----
with: otherCollection collect: twoArgBlock
"Collect and return the result of evaluating twoArgBlock with
corresponding elements from this collection and otherCollection."
| result |
otherCollection size = self size ifFalse: [self error: 'otherCollection must be the same size'].
result _ self species new: self size.
1 to: self size do:
[:index | result addLast: (twoArgBlock value: (self at: index)
value: (otherCollection at: index))].
^ result!
----- Method: OrderedCollection>>withIndexCollect: (in category 'enumerating') -----
withIndexCollect: elementAndIndexBlock
"Just like with:collect: except that the iteration index supplies the second argument to the block. Override superclass in order to use addLast:, not at:put:."
| newCollection |
newCollection _ self species new: self size.
firstIndex to: lastIndex do:
[:index |
newCollection addLast: (elementAndIndexBlock
value: (array at: index)
value: index - firstIndex + 1)].
^ newCollection!
OrderedCollection subclass: #SortedCollection
instanceVariableNames: 'sortBlock'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Sequenceable'!
!SortedCollection commentStamp: '<historical>' prior: 0!
I represent a collection of objects ordered by some property of the objects themselves. The ordering is specified in a BlockContext.!
----- Method: SortedCollection class>>new: (in category 'instance creation') -----
new: anInteger
"The default sorting function is a <= comparison on elements."
^(super new: anInteger) "sortBlock: [:x :y | x <= y]" "nil sortBlock OK"!
----- Method: SortedCollection class>>sortBlock: (in category 'instance creation') -----
sortBlock: aBlock
"Answer an instance of me such that its elements are sorted according to
the criterion specified in aBlock."
^(super new: 10) sortBlock: aBlock!
----- Method: SortedCollection>>= (in category 'comparing') -----
= aSortedCollection
"Answer true if my and aSortedCollection's species are the same,
and if our blocks are the same, and if our elements are the same."
self species = aSortedCollection species ifFalse: [^ false].
sortBlock = aSortedCollection sortBlock
ifTrue: [^ super = aSortedCollection]
ifFalse: [^ false]!
----- Method: SortedCollection>>add: (in category 'adding') -----
add: newObject
^ super insert: newObject before: (self indexForInserting: newObject)!
----- Method: SortedCollection>>addAll: (in category 'adding') -----
addAll: aCollection
aCollection size > (self size // 3)
ifTrue:
[aCollection do: [:each | self addLast: each].
self reSort]
ifFalse: [aCollection do: [:each | self add: each]].
^ aCollection!
----- Method: SortedCollection>>addFirst: (in category 'adding') -----
addFirst: newObject
self shouldNotImplement!
----- Method: SortedCollection>>at:put: (in category 'accessing') -----
at: anInteger put: anObject
self shouldNotImplement!
----- Method: SortedCollection>>collect: (in category 'enumerating') -----
collect: aBlock
"Evaluate aBlock with each of my elements as the argument. Collect the
resulting values into an OrderedCollection. Answer the new collection.
Override the superclass in order to produce an OrderedCollection instead
of a SortedCollection."
| newCollection |
newCollection _ OrderedCollection new: self size.
self do: [:each | newCollection addLast: (aBlock value: each)].
^ newCollection!
----- Method: SortedCollection>>copy (in category 'copying') -----
copy
| newCollection |
newCollection _ self species sortBlock: sortBlock.
newCollection addAll: self.
^newCollection!
----- Method: SortedCollection>>copyEmpty (in category 'adding') -----
copyEmpty
"Answer a copy of the receiver without any of the receiver's elements."
^self species sortBlock: sortBlock!
----- Method: SortedCollection>>defaultSort:to: (in category 'private') -----
defaultSort: i to: j
"Sort elements i through j of self to be nondescending according to
sortBlock." "Assume the default sort block ([:x :y | x <= y])."
| di dij dj tt ij k l n |
"The prefix d means the data at that index."
(n _ j + 1 - i) <= 1 ifTrue: [^self]. "Nothing to sort."
"Sort di,dj."
di _ array at: i.
dj _ array at: j.
(di <= dj) "i.e., should di precede dj?"
ifFalse:
[array swap: i with: j.
tt _ di.
di _ dj.
dj _ tt].
n > 2
ifTrue: "More than two elements."
[ij _ (i + j) // 2. "ij is the midpoint of i and j."
dij _ array at: ij. "Sort di,dij,dj. Make dij be their median."
(di <= dij) "i.e. should di precede dij?"
ifTrue:
[(dij <= dj) "i.e., should dij precede dj?"
ifFalse:
[array swap: j with: ij.
dij _ dj]]
ifFalse: "i.e. di should come after dij"
[array swap: i with: ij.
dij _ di].
n > 3
ifTrue: "More than three elements."
["Find k>i and l<j such that dk,dij,dl are in reverse order.
Swap k and l. Repeat this procedure until k and l pass each other."
k _ i.
l _ j.
[[l _ l - 1. k <= l and: [dij <= (array at: l)]]
whileTrue. "i.e. while dl succeeds dij"
[k _ k + 1. k <= l and: [(array at: k) <= dij]]
whileTrue. "i.e. while dij succeeds dk"
k <= l]
whileTrue:
[array swap: k with: l].
"Now l<k (either 1 or 2 less), and di through dl are all less than or equal to dk
through dj. Sort those two segments."
self defaultSort: i to: l.
self defaultSort: k to: j]]!
----- Method: SortedCollection>>indexForInserting: (in category 'private') -----
indexForInserting: newObject
| index low high |
low _ firstIndex.
high _ lastIndex.
sortBlock isNil
ifTrue: [[index _ high + low // 2. low > high]
whileFalse:
[((array at: index) <= newObject)
ifTrue: [low _ index + 1]
ifFalse: [high _ index - 1]]]
ifFalse: [[index _ high + low // 2. low > high]
whileFalse:
[(sortBlock value: (array at: index) value: newObject)
ifTrue: [low _ index + 1]
ifFalse: [high _ index - 1]]].
^low!
----- Method: SortedCollection>>insert:before: (in category 'private') -----
insert: anObject before: spot
self shouldNotImplement!
----- Method: SortedCollection>>median (in category 'accessing') -----
median
"Return the middle element, or as close as we can get."
^ self at: self size + 1 // 2!
----- Method: SortedCollection>>reSort (in category 'private') -----
reSort
self sort: firstIndex to: lastIndex!
----- Method: SortedCollection>>sort: (in category 'sorting') -----
sort: aSortBlock
"Sort this collection using aSortBlock. The block should take two arguments
and return true if the first element should preceed the second one.
If aSortBlock is nil then <= is used for comparison."
super sort: aSortBlock.
sortBlock := aSortBlock!
----- Method: SortedCollection>>sort:to: (in category 'private') -----
sort: i to: j
"Sort elements i through j of self to be nondescending according to
sortBlock."
| di dij dj tt ij k l n |
sortBlock ifNil: [^self defaultSort: i to: j].
"The prefix d means the data at that index."
(n _ j + 1 - i) <= 1 ifTrue: [^self]. "Nothing to sort."
"Sort di,dj."
di _ array at: i.
dj _ array at: j.
(sortBlock value: di value: dj) "i.e., should di precede dj?"
ifFalse:
[array swap: i with: j.
tt _ di.
di _ dj.
dj _ tt].
n > 2
ifTrue: "More than two elements."
[ij _ (i + j) // 2. "ij is the midpoint of i and j."
dij _ array at: ij. "Sort di,dij,dj. Make dij be their median."
(sortBlock value: di value: dij) "i.e. should di precede dij?"
ifTrue:
[(sortBlock value: dij value: dj) "i.e., should dij precede dj?"
ifFalse:
[array swap: j with: ij.
dij _ dj]]
ifFalse: "i.e. di should come after dij"
[array swap: i with: ij.
dij _ di].
n > 3
ifTrue: "More than three elements."
["Find k>i and l<j such that dk,dij,dl are in reverse order.
Swap k and l. Repeat this procedure until k and l pass each other."
k _ i.
l _ j.
[[l _ l - 1. k <= l and: [sortBlock value: dij value: (array at: l)]]
whileTrue. "i.e. while dl succeeds dij"
[k _ k + 1. k <= l and: [sortBlock value: (array at: k) value: dij]]
whileTrue. "i.e. while dij succeeds dk"
k <= l]
whileTrue:
[array swap: k with: l].
"Now l<k (either 1 or 2 less), and di through dl are all less than or equal to dk
through dj. Sort those two segments."
self sort: i to: l.
self sort: k to: j]]!
----- Method: SortedCollection>>sortBlock (in category 'accessing') -----
sortBlock
"Answer the blockContext which is the criterion for sorting elements of
the receiver."
^sortBlock!
----- Method: SortedCollection>>sortBlock: (in category 'accessing') -----
sortBlock: aBlock
"Make the argument, aBlock, be the criterion for ordering elements of the
receiver."
aBlock
ifNotNil: [sortBlock := aBlock fixTemps]
ifNil: [sortBlock := aBlock].
"The sortBlock must copy its home context, so as to avoid circularities!!"
"Therefore sortBlocks with side effects may not work right"
self size > 0 ifTrue: [self reSort]!
----- Method: SequenceableCollection class>>new:streamContents: (in category 'stream creation') -----
new: newSize streamContents: blockWithArg
| stream |
stream := WriteStream on: (self new: newSize).
blockWithArg value: stream.
stream position = newSize
ifTrue: [ ^stream originalContents ]
ifFalse: [ ^stream contents ]!
----- Method: SequenceableCollection class>>streamContents: (in category 'stream creation') -----
streamContents: blockWithArg
| stream |
stream _ WriteStream on: (self new: 100).
blockWithArg value: stream.
^stream contents!
----- Method: SequenceableCollection class>>streamContents:limitedTo: (in category 'stream creation') -----
streamContents: blockWithArg limitedTo: sizeLimit
| stream |
stream _ LimitedWriteStream on: (self new: (100 min: sizeLimit)).
stream setLimit: sizeLimit limitBlock: [^ stream contents].
blockWithArg value: stream.
^ stream contents
"
String streamContents: [:s | 1000 timesRepeat: [s nextPutAll: 'Junk']] limitedTo: 25
'JunkJunkJunkJunkJunkJunkJ'
"!
----- Method: SequenceableCollection>>, (in category 'copying') -----
, otherCollection
"Concatenate two Strings or Collections."
^ self copyReplaceFrom: self size + 1
to: self size
with: otherCollection
"
#(2 4 6 8) , #(who do we appreciate)
((2989 printStringBase: 16) copyFrom: 4 to: 6) , ' boy!!'
"!
----- Method: SequenceableCollection>>= (in category 'comparing') -----
= otherCollection
"Answer true if the receiver is equivalent to the otherCollection.
First test for identity, then rule out different species and sizes of
collections. As a last resort, examine each element of the receiver
and the otherCollection."
self == otherCollection ifTrue: [^ true].
self species == otherCollection species ifFalse: [^ false].
^ self hasEqualElements: otherCollection!
----- Method: SequenceableCollection>>@ (in category 'converting') -----
@ aCollection
^ self with: aCollection collect: [:a :b | a @ b]!
----- Method: SequenceableCollection>>after: (in category 'accessing') -----
after: target
"Answer the element after target. Raise an error if target is not
in the receiver, or if there are no elements after it."
^ self after: target ifAbsent: [self errorNotFound: target]!
----- Method: SequenceableCollection>>after:ifAbsent: (in category 'accessing') -----
after: target ifAbsent: exceptionBlock
"Answer the element after target. Answer the result of evaluation
the exceptionBlock if target is not in the receiver, or if there are
no elements after it."
| index |
index _ self indexOf: target.
^ index == 0
ifTrue: [exceptionBlock value]
ifFalse: [index = self size
ifTrue: [exceptionBlock value]
ifFalse: [self at: index + 1]]!
----- Method: SequenceableCollection>>allButFirst (in category 'accessing') -----
allButFirst
"Answer a copy of the receiver containing all but the first
element. Raise an error if there are not enough elements."
^ self allButFirst: 1!
----- Method: SequenceableCollection>>allButFirst: (in category 'accessing') -----
allButFirst: n
"Answer a copy of the receiver containing all but the first n
elements. Raise an error if there are not enough elements."
^ self copyFrom: n + 1 to: self size!
----- Method: SequenceableCollection>>allButFirstDo: (in category 'enumerating') -----
allButFirstDo: block
2 to: self size do:
[:index | block value: (self at: index)]!
----- Method: SequenceableCollection>>allButLast (in category 'accessing') -----
allButLast
"Answer a copy of the receiver containing all but the last
element. Raise an error if there are not enough elements."
^ self allButLast: 1!
----- Method: SequenceableCollection>>allButLast: (in category 'accessing') -----
allButLast: n
"Answer a copy of the receiver containing all but the last n
elements. Raise an error if there are not enough elements."
^ self copyFrom: 1 to: self size - n!
----- Method: SequenceableCollection>>allButLastDo: (in category 'enumerating') -----
allButLastDo: block
1 to: self size - 1 do:
[:index | block value: (self at: index)]!
----- Method: SequenceableCollection>>anyOne (in category 'accessing') -----
anyOne
^ self first!
----- Method: SequenceableCollection>>asArray (in category 'converting') -----
asArray
"Answer an Array whose elements are the elements of the receiver."
^ Array withAll: self!
----- Method: SequenceableCollection>>asByteArray (in category 'converting') -----
asByteArray
"Answer a ByteArray whose elements are the elements of the receiver."
^ ByteArray withAll: self!
----- Method: SequenceableCollection>>asColorArray (in category 'converting') -----
asColorArray
^ColorArray withAll: self!
----- Method: SequenceableCollection>>asDigitsAt:in:do: (in category 'private') -----
asDigitsAt: anInteger in: aCollection do: aBlock
"(0 to: 1) asDigitsToPower: 4 do: [:each | Transcript cr; show: each printString]"
self do:
[:each |
aCollection at: anInteger put: each.
anInteger = aCollection size
ifTrue: [aBlock value: aCollection]
ifFalse: [self asDigitsAt: anInteger + 1 in: aCollection do: aBlock]].!
----- Method: SequenceableCollection>>asDigitsToPower:do: (in category 'enumerating') -----
asDigitsToPower: anInteger do: aBlock
"Repeatedly value aBlock with a single Array. Adjust the collection
so that aBlock is presented all (self size raisedTo: anInteger) possible
combinations of the receiver's elements taken as digits of an anInteger long number."
"(0 to: 1) asDigitsToPower: 4 do: [:each | Transcript cr; show: each printString]"
| aCollection |
aCollection _ Array new: anInteger.
self asDigitsAt: 1 in: aCollection do: aBlock!
----- Method: SequenceableCollection>>asFloatArray (in category 'converting') -----
asFloatArray
"Answer a FloatArray whose elements are the elements of the receiver, in
the same order."
| floatArray |
floatArray _ FloatArray new: self size.
1 to: self size do:[:i| floatArray at: i put: (self at: i) asFloat ].
^floatArray!
----- Method: SequenceableCollection>>asIntegerArray (in category 'converting') -----
asIntegerArray
"Answer an IntegerArray whose elements are the elements of the receiver, in
the same order."
| intArray |
intArray _ IntegerArray new: self size.
1 to: self size do:[:i| intArray at: i put: (self at: i)].
^intArray!
----- Method: SequenceableCollection>>asPointArray (in category 'converting') -----
asPointArray
"Answer an PointArray whose elements are the elements of the receiver, in
the same order."
| pointArray |
pointArray _ PointArray new: self size.
1 to: self size do:[:i| pointArray at: i put: (self at: i)].
^pointArray!
----- Method: SequenceableCollection>>asStringWithCr (in category 'converting') -----
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 isString
ifTrue: [labelStream nextPutAll: each; cr]
ifFalse: [each printOn: labelStream. labelStream cr]].
self size > 0 ifTrue: [labelStream skip: -1].
^ labelStream contents!
----- Method: SequenceableCollection>>asWordArray (in category 'converting') -----
asWordArray
"Answer a WordArray whose elements are the elements of the receiver, in
the same order."
| wordArray |
wordArray _ WordArray new: self size.
1 to: self size do:[:i| wordArray at: i put: (self at: i)].
^wordArray!
----- Method: SequenceableCollection>>at:ifAbsent: (in category 'accessing') -----
at: index ifAbsent: exceptionBlock
"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!
----- Method: SequenceableCollection>>at:incrementBy: (in category 'accessing') -----
at: index incrementBy: value
^self at: index put: (self at: index) + value!
----- Method: SequenceableCollection>>atAll: (in category 'accessing') -----
atAll: indexArray
"Answer a new collection like the receiver which contains all elements
of the receiver at the indices of indexArray."
"#('one' 'two' 'three' 'four') atAll: #(3 2 4)"
| newCollection |
newCollection _ self species ofSize: indexArray size.
1 to: indexArray size do:
[:index |
newCollection at: index put: (self at: (indexArray at: index))].
^ newCollection!
----- Method: SequenceableCollection>>atAll:put: (in category 'accessing') -----
atAll: aCollection put: anObject
"Put anObject at every index specified by the elements of aCollection."
aCollection do: [:index | self at: index put: anObject].
^ anObject!
----- Method: SequenceableCollection>>atAll:putAll: (in category 'accessing') -----
atAll: indexArray putAll: valueArray
"Store the elements of valueArray into the slots
of this collection selected by indexArray."
indexArray with: valueArray do: [:index :value | self at: index put: value].
^ valueArray!
----- Method: SequenceableCollection>>atAllPut: (in category 'accessing') -----
atAllPut: anObject
"Put anObject at every one of the receiver's indices."
| size |
(size _ self size) > 26 "first method faster from 27 accesses and on"
ifTrue: [self from: 1 to: size put: anObject]
ifFalse: [1 to: size do: [:index | self at: index put: anObject]]!
----- Method: SequenceableCollection>>atLast: (in category 'accessing') -----
atLast: indexFromEnd
"Return element at indexFromEnd from the last position.
atLast: 1, returns the last element"
^ self atLast: indexFromEnd ifAbsent: [self error: 'index out of range']!
----- Method: SequenceableCollection>>atLast:ifAbsent: (in category 'accessing') -----
atLast: indexFromEnd ifAbsent: block
"Return element at indexFromEnd from the last position.
atLast: 1 ifAbsent: [] returns the last element"
^ self at: self size + 1 - indexFromEnd ifAbsent: block!
----- Method: SequenceableCollection>>atLast:put: (in category 'accessing') -----
atLast: indexFromEnd put: obj
"Set the element at indexFromEnd from the last position.
atLast: 1 put: obj, sets the last element"
^ self at: self size + 1 - indexFromEnd put: obj!
----- Method: SequenceableCollection>>atPin: (in category 'accessing') -----
atPin: index
"Return the index'th element of me if possible.
Return the first or last element if index is out of bounds."
index < 1 ifTrue: [^ self first].
index > self size ifTrue: [^ self last].
^ self at: index!
----- Method: SequenceableCollection>>atRandom: (in category 'accessing') -----
atRandom: aGenerator
"Answer a random element of the receiver. Uses aGenerator which
should be kept by the user in a variable and used 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."
^ self at: (aGenerator nextInt: self size)!
----- Method: SequenceableCollection>>atWrap: (in category 'accessing') -----
atWrap: index
"Answer the index'th element of the receiver. If index is out of bounds,
let it wrap around from the end to the beginning until it is in bounds."
^ self at: index - 1 \\ self size + 1!
----- Method: SequenceableCollection>>atWrap:put: (in category 'accessing') -----
atWrap: index put: value
"Store value into the index'th element of the receiver. If index is out
of bounds, let it wrap around from the end to the beginning until it
is in bounds. Answer value."
^ self at: index - 1 \\ self size + 1 put: value!
----- Method: SequenceableCollection>>before: (in category 'accessing') -----
before: target
"Answer the receiver's element immediately before target. Raise an
error if target is not an element of the receiver, or if there are no
elements before it (i.e. it is the first element)."
^ self before: target ifAbsent: [self errorNotFound: target]!
----- Method: SequenceableCollection>>before:ifAbsent: (in category 'accessing') -----
before: target ifAbsent: exceptionBlock
"Answer the receiver's element immediately before target. Answer
the result of evaluating the exceptionBlock if target is not an element
of the receiver, or if there are no elements before it."
| index |
index _ self indexOf: target.
^ index == 0
ifTrue: [exceptionBlock value]
ifFalse: [index == 1
ifTrue: [exceptionBlock value]
ifFalse: [self at: index - 1]]!
----- Method: SequenceableCollection>>beginsWith: (in category 'testing') -----
beginsWith: aSequenceableCollection
(aSequenceableCollection isEmpty or: [self size < aSequenceableCollection size]) ifTrue: [^false].
aSequenceableCollection withIndexDo: [:each :index | (self at: index) ~= each ifTrue: [^false]].
^true!
----- Method: SequenceableCollection>>collect: (in category 'enumerating') -----
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
the new collection."
| newCollection |
newCollection _ self species new: self size.
1 to: self size do:
[:index |
newCollection at: index put: (aBlock value: (self at: index))].
^ newCollection!
----- Method: SequenceableCollection>>collect:from:to: (in category 'enumerating') -----
collect: aBlock from: firstIndex to: lastIndex
"Refer to the comment in Collection|collect:."
| size result j |
size _ lastIndex - firstIndex + 1.
result _ self species new: size.
j _ firstIndex.
1 to: size do: [:i | result at: i put: (aBlock value: (self at: j)). j _ j + 1].
^ result!
----- Method: SequenceableCollection>>collectWithIndex: (in category 'enumerating') -----
collectWithIndex: elementAndIndexBlock
"Use the new version with consistent naming"
^ self withIndexCollect: elementAndIndexBlock!
----- Method: SequenceableCollection>>combinations:atATimeDo: (in category 'enumerating') -----
combinations: kk atATimeDo: aBlock
"Take the items in the receiver, kk at a time, and evaluate the block for each combination. Hand in an array of elements of self as the block argument. Each combination only occurs once, and order of the elements does not matter. There are (self size take: kk) combinations."
" 'abcde' combinations: 3 atATimeDo: [:each | Transcript cr; show: each printString]"
| aCollection |
aCollection _ Array new: kk.
self combinationsAt: 1 in: aCollection after: 0 do: aBlock!
----- Method: SequenceableCollection>>combinationsAt:in:after:do: (in category 'private') -----
combinationsAt: jj in: aCollection after: nn do: aBlock
"Choose k of N items and put in aCollection. jj-1 already chosen. Indexes of items are in numerical order, to avoid the same combo being used twice. In this slot, we are allowed to use items in self indexed by nn+1 to self size. nn is the index used for position jj-1."
"(1 to: 6) combinationsSize: 3 do: [:each | Transcript cr; show: each printString]"
nn+1 to: self size do: [:index |
aCollection at: jj put: (self at: index).
jj = aCollection size
ifTrue: [aBlock value: aCollection]
ifFalse: [self combinationsAt: jj + 1 in: aCollection after: index do: aBlock]].!
----- Method: SequenceableCollection>>concatenation (in category 'converting') -----
concatenation
|result index|
result _ Array new: (self inject: 0 into: [:sum :each | sum + each size]).
index _ 0.
self do: [:each | each do: [:item | result at: (index _ index+1) put: item]].
^result!
----- Method: SequenceableCollection>>copyAfter: (in category 'copying') -----
copyAfter: anElement
"Answer a copy of the receiver from after the first occurence
of anElement up to the end. If no such element exists, answer
an empty copy."
^ self allButFirst: (self indexOf: anElement ifAbsent: [^ self copyEmpty])!
----- Method: SequenceableCollection>>copyAfterLast: (in category 'copying') -----
copyAfterLast: anElement
"Answer a copy of the receiver from after the last occurence
of anElement up to the end. If no such element exists, answer
an empty copy."
^ self allButFirst: (self lastIndexOf: anElement ifAbsent: [^ self copyEmpty])!
----- Method: SequenceableCollection>>copyEmpty (in category 'copying') -----
copyEmpty
^ self species new: 0!
----- Method: SequenceableCollection>>copyFrom:to: (in category 'copying') -----
copyFrom: start to: stop
"Answer a copy of a subset of the receiver, starting from element at
index start until element at index stop."
| newSize |
newSize _ stop - start + 1.
^(self species new: newSize)
replaceFrom: 1
to: newSize
with: self
startingAt: start!
----- Method: SequenceableCollection>>copyLast: (in category 'copying') -----
copyLast: num
"Deprecated. Use #last:"
^ self last: num!
----- Method: SequenceableCollection>>copyReplaceAll:with: (in category 'copying') -----
copyReplaceAll: oldSubstring with: newSubstring
"Default is not to do token matching.
See also String copyReplaceTokens:with:"
^ self copyReplaceAll: oldSubstring with: newSubstring asTokens: false
"'How now brown cow?' copyReplaceAll: 'ow' with: 'ello'"
"'File asFile Files File''s File' copyReplaceTokens: 'File' with: 'Pile'"!
----- Method: SequenceableCollection>>copyReplaceAll:with:asTokens: (in category 'private') -----
copyReplaceAll: oldSubstring with: newSubstring asTokens: ifTokens
"Answer a copy of the receiver in which all occurrences of
oldSubstring have been replaced by newSubstring.
ifTokens (valid for Strings only) specifies that the characters
surrounding the recplacement must not be alphanumeric.
Bruce Simth, must be incremented by 1 and not
newSubstring if ifTokens is true. See example below. "
| aString startSearch currentIndex endIndex |
(ifTokens and: [(self isString) not])
ifTrue: [(self isKindOf: Text) ifFalse: [
self error: 'Token replacement only valid for Strings']].
aString _ self.
startSearch _ 1.
[(currentIndex _ aString indexOfSubCollection: oldSubstring startingAt: startSearch)
> 0]
whileTrue:
[endIndex _ currentIndex + oldSubstring size - 1.
(ifTokens not
or: [(currentIndex = 1
or: [(aString at: currentIndex-1) isAlphaNumeric not])
and: [endIndex = aString size
or: [(aString at: endIndex+1) isAlphaNumeric not]]])
ifTrue: [aString _ aString
copyReplaceFrom: currentIndex
to: endIndex
with: newSubstring.
startSearch _ currentIndex + newSubstring size]
ifFalse: [
ifTokens
ifTrue: [startSearch _ currentIndex + 1]
ifFalse: [startSearch _ currentIndex + newSubstring size]]].
^ aString
"Test case:
'test te string' copyReplaceAll: 'te' with: 'longone' asTokens: true "
!
----- Method: SequenceableCollection>>copyReplaceFrom:to:with: (in category 'copying') -----
copyReplaceFrom: start to: stop with: replacementCollection
"Answer a copy of the receiver satisfying the following conditions: If
stop is less than start, then this is an insertion; stop should be exactly
start-1, start = 1 means insert before the first character, start = size+1
means append after last character. Otherwise, this is a replacement; start
and stop have to be within the receiver's bounds."
| newSequenceableCollection newSize endReplacement |
newSize _ self size - (stop - start + 1) + replacementCollection size.
endReplacement _ start - 1 + replacementCollection size.
newSequenceableCollection _ self species new: newSize.
start > 1 ifTrue:[
newSequenceableCollection
replaceFrom: 1
to: start - 1
with: self
startingAt: 1].
start <= endReplacement ifTrue:[
newSequenceableCollection
replaceFrom: start
to: endReplacement
with: replacementCollection
startingAt: 1].
endReplacement < newSize ifTrue:[
newSequenceableCollection
replaceFrom: endReplacement + 1
to: newSize
with: self
startingAt: stop + 1].
^newSequenceableCollection!
----- Method: SequenceableCollection>>copyUpTo: (in category 'copying') -----
copyUpTo: anElement
"Answer all elements up to but not including anObject. If there
is no such object, answer a copy of the receiver."
^ self first: (self indexOf: anElement ifAbsent: [^ self copy]) - 1!
----- Method: SequenceableCollection>>copyUpToLast: (in category 'copying') -----
copyUpToLast: anElement
"Answer a copy of the receiver from index 1 to the last occurrence of
anElement, not including anElement."
^ self first: (self lastIndexOf: anElement ifAbsent: [^ self copy]) - 1!
----- Method: SequenceableCollection>>copyWith: (in category 'copying') -----
copyWith: newElement
"Answer a copy of the receiver that is 1 bigger than the receiver and has
newElement at the last element."
| newIC |
newIC _ self species new: self size + 1.
newIC
replaceFrom: 1
to: self size
with: self
startingAt: 1.
newIC at: newIC size put: newElement.
^newIC!
----- Method: SequenceableCollection>>copyWithFirst: (in category 'copying') -----
copyWithFirst: newElement
"Answer a copy of the receiver that is 1 bigger than the receiver with newElement as the first element."
| newIC |
newIC _ self species ofSize: self size + 1.
newIC
replaceFrom: 2
to: self size + 1
with: self
startingAt: 1.
newIC at: 1 put: newElement.
^ newIC!
----- Method: SequenceableCollection>>copyWithoutFirst (in category 'copying') -----
copyWithoutFirst
"Deprecatd. Return a copy of the receiver which doesn't include
the first element."
^ self allButFirst!
----- Method: SequenceableCollection>>copyWithoutIndex: (in category 'copying') -----
copyWithoutIndex: index
"Return a copy containing all elements except the index-th."
| copy |
copy := self species ofSize: self size - 1.
copy replaceFrom: 1 to: index-1 with: self startingAt: 1.
copy replaceFrom: index to: copy size with: self startingAt: index+1.
^ copy!
----- Method: SequenceableCollection>>customizeExplorerContents (in category 'accessing') -----
customizeExplorerContents
^ true.
!
----- Method: SequenceableCollection>>do: (in category 'enumerating') -----
do: aBlock
"Refer to the comment in Collection|do:."
1 to: self size do:
[:index | aBlock value: (self at: index)]!
----- Method: SequenceableCollection>>do:displayingProgress: (in category 'enumerating') -----
do: aBlock displayingProgress: aString
aString
displayProgressAt: Sensor cursorPoint
from: 0 to: self size
during:
[:bar |
self withIndexDo:
[:each :i |
bar value: i.
aBlock value: each]]!
----- Method: SequenceableCollection>>do:separatedBy: (in category 'enumerating') -----
do: elementBlock separatedBy: separatorBlock
"Evaluate the elementBlock for all elements in the receiver,
and evaluate the separatorBlock between."
1 to: self size do:
[:index |
index = 1 ifFalse: [separatorBlock value].
elementBlock value: (self at: index)]!
----- Method: SequenceableCollection>>do:without: (in category 'enumerating') -----
do: aBlock without: anItem
"Enumerate all elements in the receiver.
Execute aBlock for those elements that are not equal to the given item"
"Refer to the comment in Collection|do:."
1 to: self size do:
[:index | anItem = (self at: index) ifFalse:[aBlock value: (self at: index)]]!
----- Method: SequenceableCollection>>doWithIndex: (in category 'enumerating') -----
doWithIndex: elementAndIndexBlock
"Use the new version with consistent naming"
^ self withIndexDo: elementAndIndexBlock!
----- Method: SequenceableCollection>>eighth (in category 'accessing') -----
eighth
"Answer the eighth element of the receiver.
Raise an error if there are not enough elements."
^ self at: 8!
----- Method: SequenceableCollection>>endsWith: (in category 'testing') -----
endsWith: aSequenceableCollection
| start |
(aSequenceableCollection isEmpty or: [self size < aSequenceableCollection size]) ifTrue: [^false].
start _ self size - aSequenceableCollection size.
aSequenceableCollection withIndexDo: [:each :index | (self at: start + index) ~= each ifTrue: [^false]].
^true!
----- Method: SequenceableCollection>>errorOutOfBounds (in category 'private') -----
errorOutOfBounds
self error: 'indices are out of bounds'!
----- Method: SequenceableCollection>>fifth (in category 'accessing') -----
fifth
"Answer the fifth element of the receiver.
Raise an error if there are not enough elements."
^ self at: 5!
----- Method: SequenceableCollection>>findBinary: (in category 'enumerating') -----
findBinary: aBlock
"Search for an element in the receiver using binary search.
The argument aBlock is a one-element block returning
0 - if the element is the one searched for
<0 - if the search should continue in the first half
>0 - if the search should continue in the second half
If no matching element is found, raise an error.
Examples:
#(1 3 5 7 11 15 23) findBinary:[:arg| 11 - arg]
"
^self findBinary: aBlock ifNone: [self errorNotFound: aBlock]!
----- Method: SequenceableCollection>>findBinary:ifNone: (in category 'enumerating') -----
findBinary: aBlock ifNone: exceptionBlock
"Search for an element in the receiver using binary search.
The argument aBlock is a one-element block returning
0 - if the element is the one searched for
<0 - if the search should continue in the first half
>0 - if the search should continue in the second half
If no matching element is found, evaluate exceptionBlock."
| index low high test item |
low _ 1.
high _ self size.
[index _ high + low // 2.
low > high] whileFalse:[
test _ aBlock value: (item _ self at: index).
test = 0
ifTrue:[^item]
ifFalse:[test > 0
ifTrue: [low _ index + 1]
ifFalse: [high _ index - 1]]].
^exceptionBlock value!
----- Method: SequenceableCollection>>findBinaryIndex: (in category 'enumerating') -----
findBinaryIndex: aBlock
"Search for an element in the receiver using binary search.
The argument aBlock is a one-element block returning
0 - if the element is the one searched for
<0 - if the search should continue in the first half
>0 - if the search should continue in the second half
If no matching element is found, raise an error.
Examples:
#(1 3 5 7 11 15 23) findBinaryIndex:[:arg| 11 - arg]
"
^self findBinaryIndex: aBlock ifNone: [self errorNotFound: aBlock]!
----- Method: SequenceableCollection>>findBinaryIndex:ifNone: (in category 'enumerating') -----
findBinaryIndex: aBlock ifNone: exceptionBlock
"Search for an element in the receiver using binary search.
The argument aBlock is a one-element block returning
0 - if the element is the one searched for
<0 - if the search should continue in the first half
>0 - if the search should continue in the second half
If no matching element is found, evaluate exceptionBlock."
| index low high test |
low _ 1.
high _ self size.
[index _ high + low // 2.
low > high] whileFalse:[
test _ aBlock value: (self at: index).
test = 0
ifTrue:[^index]
ifFalse:[test > 0
ifTrue: [low _ index + 1]
ifFalse: [high _ index - 1]]].
^exceptionBlock value!
----- Method: SequenceableCollection>>findFirst: (in category 'enumerating') -----
findFirst: aBlock
"Return the index of my first element for which aBlock evaluates as true."
| index |
index _ 0.
[(index _ index + 1) <= self size] whileTrue:
[(aBlock value: (self at: index)) ifTrue: [^index]].
^ 0!
----- Method: SequenceableCollection>>findLast: (in category 'enumerating') -----
findLast: aBlock
"Return the index of my last element for which aBlock evaluates as true."
| index |
index _ self size + 1.
[(index _ index - 1) >= 1] whileTrue:
[(aBlock value: (self at: index)) ifTrue: [^index]].
^ 0!
----- Method: SequenceableCollection>>first (in category 'accessing') -----
first
"Answer the first element of the receiver."
^ self at: 1!
----- Method: SequenceableCollection>>first: (in category 'accessing') -----
first: n
"Answer the first n elements of the receiver.
Raise an error if there are not enough elements."
^ self copyFrom: 1 to: n!
----- Method: SequenceableCollection>>forceTo:paddingStartWith: (in category 'copying') -----
forceTo: length paddingStartWith: elem
"Force the length of the collection to length, padding
the beginning of the result if necessary with elem.
Note that this makes a copy."
| newCollection padLen |
newCollection _ self species new: length.
padLen _ length - self size max: 0.
newCollection
from: 1
to: padLen
put: elem.
newCollection
replaceFrom: padLen + 1
to: ((padLen + self size) min: length)
with: self
startingAt: 1.
^ newCollection!
----- Method: SequenceableCollection>>forceTo:paddingWith: (in category 'copying') -----
forceTo: length paddingWith: elem
"Force the length of the collection to length, padding
if necessary with elem. Note that this makes a copy."
| newCollection copyLen |
newCollection _ self species new: length.
copyLen _ self size min: length.
newCollection replaceFrom: 1 to: copyLen with: self startingAt: 1.
newCollection from: copyLen + 1 to: length put: elem.
^ newCollection!
----- Method: SequenceableCollection>>fourth (in category 'accessing') -----
fourth
"Answer the fourth element of the receiver.
Raise an error if there are not enough elements."
^ self at: 4!
----- Method: SequenceableCollection>>from:to:do: (in category 'enumerating') -----
from: start to: stop do: aBlock
"Evaluate aBlock for all elements between start and stop (inclusive)."
start to: stop do: [:index | aBlock value: (self at: index)]!
----- Method: SequenceableCollection>>from:to:put: (in category 'accessing') -----
from: startIndex to: endIndex put: anObject
"Put anObject in all indexes between startIndex
and endIndex. Very fast. Faster than to:do: for
more than 26 positions. Answer anObject"
| written toWrite thisWrite |
startIndex > endIndex ifTrue: [^self].
self at: startIndex put: anObject.
written _ 1.
toWrite _ endIndex - startIndex + 1.
[written < toWrite] whileTrue:
[
thisWrite _ written min: toWrite - written.
self
replaceFrom: startIndex + written
to: startIndex + written + thisWrite - 1
with: self startingAt: startIndex.
written _ written + thisWrite
].
^anObject!
----- Method: SequenceableCollection>>groupsOf:atATimeCollect: (in category 'enumerating') -----
groupsOf: n atATimeCollect: aBlock
"Evaluate aBlock with my elements taken n at a time. Ignore any
leftovers at the end.
Allows use of a flattened
array for things that naturally group into groups of n.
If aBlock has a single argument, pass it an array of n items,
otherwise, pass the items as separate arguments.
See also pairsDo:"
| passArray args |
passArray := aBlock numArgs = 1.
^(n
to: self size
by: n)
collect: [:index |
args := (self copyFrom: index - n + 1 to: index) asArray.
passArray
ifTrue: [aBlock value: args]
ifFalse: [aBlock valueWithArguments: args]]!
----- Method: SequenceableCollection>>groupsOf:atATimeDo: (in category 'enumerating') -----
groupsOf: n atATimeDo: aBlock
"Evaluate aBlock with my elements taken n at a time. Ignore any leftovers at the end.
Allows use of a flattened
array for things that naturally group into groups of n.
If aBlock has a single argument, pass it an array of n items,
otherwise, pass the items as separate arguments.
See also pairsDo:"
| passArray args |
passArray := (aBlock numArgs = 1).
n
to: self size
by: n
do: [:index |
args := (self copyFrom: index - n + 1 to: index) asArray.
passArray ifTrue: [ aBlock value: args ]
ifFalse: [ aBlock valueWithArguments: args ]].!
----- Method: SequenceableCollection>>hasEqualElements: (in category 'comparing') -----
hasEqualElements: otherCollection
"Answer whether the receiver's size is the same as otherCollection's
size, and each of the receiver's elements equal the corresponding
element of otherCollection.
This should probably replace the current definition of #= ."
| size |
(otherCollection isKindOf: SequenceableCollection) ifFalse: [^ false].
(size _ self size) = otherCollection size ifFalse: [^ false].
1 to: size do:
[:index |
(self at: index) = (otherCollection at: index) ifFalse: [^ false]].
^ true!
----- Method: SequenceableCollection>>hash (in category 'comparing') -----
hash
| hash |
hash _ self species hash.
1 to: self size do: [:i | hash _ (hash + (self at: i) hash) hashMultiply].
^hash!
----- Method: SequenceableCollection>>identityIndexOf: (in category 'accessing') -----
identityIndexOf: anElement
"Answer the index of anElement within the receiver. If the receiver does
not contain anElement, answer 0."
^self identityIndexOf: anElement ifAbsent: [0]!
----- Method: SequenceableCollection>>identityIndexOf:ifAbsent: (in category 'accessing') -----
identityIndexOf: 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,
exceptionBlock."
1 to: self size do:
[:i | (self at: i) == anElement ifTrue: [^ i]].
^ exceptionBlock value!
----- Method: SequenceableCollection>>includes: (in category 'testing') -----
includes: anObject
"Answer whether anObject is one of the receiver's elements."
^ (self indexOf: anObject) ~= 0!
----- Method: SequenceableCollection>>indexOf: (in category 'accessing') -----
indexOf: anElement
"Answer the index of the first occurence of anElement within the
receiver. If the receiver does not contain anElement, answer 0."
^ self indexOf: anElement ifAbsent: [0]!
----- Method: SequenceableCollection>>indexOf:ifAbsent: (in category 'accessing') -----
indexOf: anElement ifAbsent: exceptionBlock
"Answer the index of the first occurence of anElement within the
receiver. If the receiver does not contain anElement, answer the
result of evaluating the argument, exceptionBlock."
^ self indexOf: anElement startingAt: 1 ifAbsent: exceptionBlock!
----- Method: SequenceableCollection>>indexOf:startingAt:ifAbsent: (in category 'accessing') -----
indexOf: anElement startingAt: start ifAbsent: exceptionBlock
"Answer the index of the first occurence of anElement after start
within the receiver. If the receiver does not contain anElement,
answer the result of evaluating the argument, exceptionBlock."
start to: self size do:
[:index |
(self at: index) = anElement ifTrue: [^ index]].
^ exceptionBlock value!
----- Method: SequenceableCollection>>indexOfSubCollection:startingAt: (in category 'accessing') -----
indexOfSubCollection: aSubCollection startingAt: anIndex
"Answer the index of the receiver's first element, such that that element
equals the first element of aSubCollection, and the next elements equal
the rest of the elements of aSubCollection. Begin the search at element
anIndex of the receiver. If no such match is found, answer 0."
^self
indexOfSubCollection: aSubCollection
startingAt: anIndex
ifAbsent: [0]!
----- Method: SequenceableCollection>>indexOfSubCollection:startingAt:ifAbsent: (in category 'accessing') -----
indexOfSubCollection: sub startingAt: start ifAbsent: exceptionBlock
"Answer the index of the receiver's first element, such that that element
equals the first element of sub, and the next elements equal
the rest of the elements of sub. Begin the search at element
start of the receiver. If no such match is found, answer the result of
evaluating argument, exceptionBlock."
| first index |
sub isEmpty ifTrue: [^ exceptionBlock value].
first _ sub first.
start to: self size - sub size + 1 do:
[:startIndex |
(self at: startIndex) = first ifTrue:
[index _ 1.
[(self at: startIndex+index-1) = (sub at: index)]
whileTrue:
[index = sub size ifTrue: [^startIndex].
index _ index+1]]].
^ exceptionBlock value!
----- Method: SequenceableCollection>>integerAt: (in category 'accessing') -----
integerAt: index
"Return the integer at the given index"
^self at: index!
----- Method: SequenceableCollection>>integerAt:put: (in category 'accessing') -----
integerAt: index put: value
"Return the integer at the given index"
^self at: index put: value!
----- Method: SequenceableCollection>>isSequenceable (in category 'testing') -----
isSequenceable
^ true!
----- Method: SequenceableCollection>>keysAndValuesDo: (in category 'enumerating') -----
keysAndValuesDo: aBlock
"Enumerate the receiver with all the keys (aka indices) and values."
1 to: self size do: [:index | aBlock value: index value: (self at: index)]!
----- Method: SequenceableCollection>>last (in category 'accessing') -----
last
"Answer the last element of the receiver.
Raise an error if the collection is empty."
| size |
(size _ self size) = 0 ifTrue: [self errorEmptyCollection].
^ self at: size!
----- Method: SequenceableCollection>>last: (in category 'accessing') -----
last: n
"Answer the last n elements of the receiver.
Raise an error if there are not enough elements."
| size |
size _ self size.
^ self copyFrom: size - n + 1 to: size!
----- Method: SequenceableCollection>>lastIndexOf: (in category 'accessing') -----
lastIndexOf: anElement
"Answer the index of the last occurence of anElement within the
receiver. If the receiver does not contain anElement, answer 0."
^ self lastIndexOf: anElement startingAt: self size ifAbsent: [0]!
----- Method: SequenceableCollection>>lastIndexOf:ifAbsent: (in category 'accessing') -----
lastIndexOf: anElement ifAbsent: exceptionBlock
"Answer the index of the last occurence of anElement within the
receiver. If the receiver does not contain anElement, answer the
result of evaluating the argument, exceptionBlock."
^self lastIndexOf: anElement startingAt: self size ifAbsent: exceptionBlock!
----- Method: SequenceableCollection>>lastIndexOf:startingAt:ifAbsent: (in category 'accessing') -----
lastIndexOf: anElement startingAt: lastIndex ifAbsent: exceptionBlock
"Answer the index of the last occurence of anElement within the
receiver. If the receiver does not contain anElement, answer the
result of evaluating the argument, exceptionBlock."
lastIndex to: 1 by: -1 do:
[:index |
(self at: index) = anElement ifTrue: [^ index]].
^ exceptionBlock value!
----- Method: SequenceableCollection>>middle (in category 'accessing') -----
middle
"Answer the middle element of the receiver."
self emptyCheck.
^ self at: self size // 2 + 1!
----- Method: SequenceableCollection>>nextToLast (in category 'enumerating') -----
nextToLast
^self at: self size - 1!
----- Method: SequenceableCollection>>ninth (in category 'accessing') -----
ninth
"Answer the ninth element of the receiver.
Raise an error if there are not enough elements."
^ self at: 9!
----- Method: SequenceableCollection>>overlappingPairsCollect: (in category 'enumerating') -----
overlappingPairsCollect: aBlock
"Answer the result of evaluating aBlock with all of the overlapping pairs of my elements."
| retval |
retval _ self species new: self size - 1.
1 to: self size - 1
do: [:i | retval at: i put: (aBlock value: (self at: i) value: (self at: i + 1)) ].
^retval!
----- Method: SequenceableCollection>>overlappingPairsDo: (in category 'enumerating') -----
overlappingPairsDo: aBlock
"Emit overlapping pairs of my elements into aBlock"
1 to: self size - 1
do: [:i | aBlock value: (self at: i) value: (self at: i + 1)]!
----- Method: SequenceableCollection>>overlappingPairsWithIndexDo: (in category 'enumerating') -----
overlappingPairsWithIndexDo: aBlock
"Emit overlapping pairs of my elements into aBlock, along with an index."
1 to: self size - 1
do: [:i | aBlock value: (self at: i) value: (self at: i + 1) value: i ]!
----- Method: SequenceableCollection>>paddedWith:do: (in category 'enumerating') -----
paddedWith: otherCollection do: twoArgBlock
"Evaluate twoArgBlock with corresponding elements from this collection and otherCollection.
Missing elements from either will be passed as nil."
1 to: (self size max: otherCollection size) do:
[:index | twoArgBlock value: (self at: index ifAbsent: [])
value: (otherCollection at: index ifAbsent: [])]!
----- Method: SequenceableCollection>>pairsCollect: (in category 'enumerating') -----
pairsCollect: aBlock
"Evaluate aBlock with my elements taken two at a time, and return an Array with the results"
^ (1 to: self size // 2) collect:
[:index | aBlock value: (self at: 2 * index - 1) value: (self at: 2 * index)]
"
#(1 'fred' 2 'charlie' 3 'elmer') pairsCollect:
[:a :b | b, ' is number ', a printString]
"!
----- Method: SequenceableCollection>>pairsDo: (in category 'enumerating') -----
pairsDo: aBlock
"Evaluate aBlock with my elements taken two at a time. If there's an odd number of items, ignore the last one. Allows use of a flattened array for things that naturally group into pairs. See also pairsCollect:"
1 to: self size // 2 do:
[:index | aBlock value: (self at: 2 * index - 1) value: (self at: 2 * index)]
"
#(1 'fred' 2 'charlie' 3 'elmer') pairsDo:
[:a :b | Transcript cr; show: b, ' is number ', a printString]
"!
----- Method: SequenceableCollection>>permutationsDo: (in category 'enumerating') -----
permutationsDo: aBlock
"Repeatly value aBlock with a single copy of the receiver. Reorder the copy
so that aBlock is presented all (self size factorial) possible permutations."
"(1 to: 4) permutationsDo: [:each | Transcript cr; show: each printString]"
self shallowCopy permutationsStartingAt: 1 do: aBlock!
----- Method: SequenceableCollection>>permutationsStartingAt:do: (in category 'private') -----
permutationsStartingAt: anInteger do: aBlock
"#(1 2 3 4) permutationsDo: [:each | Transcript cr; show: each printString]"
anInteger > self size ifTrue: [^self].
anInteger = self size ifTrue: [^aBlock value: self].
anInteger to: self size do:
[:i | self swap: anInteger with: i.
self permutationsStartingAt: anInteger + 1 do: aBlock.
self swap: anInteger with: i]!
----- Method: SequenceableCollection>>polynomialEval: (in category 'enumerating') -----
polynomialEval: thisX
| sum valToPower |
"Treat myself as the coeficients of a polynomial in X. Evaluate it with thisX. First element is the constant and last is the coeficient for the highest power."
" #(1 2 3) polynomialEval: 2 " "is 3*X^2 + 2*X + 1 with X = 2"
sum _ self first.
valToPower _ thisX.
2 to: self size do: [:ind |
sum _ sum + ((self at: ind) * valToPower).
valToPower _ valToPower * thisX].
^ sum!
----- Method: SequenceableCollection>>readStream (in category 'converting') -----
readStream
^ ReadStream on: self!
----- Method: SequenceableCollection>>remove:ifAbsent: (in category 'removing') -----
remove: oldObject ifAbsent: anExceptionBlock
"SequencableCollections cannot implement removing."
self shouldNotImplement!
----- Method: SequenceableCollection>>replace: (in category 'enumerating') -----
replace: aBlock
"Evaluate aBlock with each of the receiver's elements as the argument.
Collect the resulting values into self."
1 to: self size do: [ :index |
self at: index put: (aBlock value: (self at: index)) ]!
----- Method: SequenceableCollection>>replaceAll:with: (in category 'accessing') -----
replaceAll: oldObject with: newObject
"Replace all occurences of oldObject with newObject"
| index |
index _ self
indexOf: oldObject
startingAt: 1
ifAbsent: [0].
[index = 0]
whileFalse:
[self at: index put: newObject.
index _ self
indexOf: oldObject
startingAt: index + 1
ifAbsent: [0]]!
----- Method: SequenceableCollection>>replaceFrom:to:with: (in category 'accessing') -----
replaceFrom: start to: stop with: replacement
"This destructively replaces elements from start to stop in the receiver.
Answer the receiver itself. Use copyReplaceFrom:to:with: for
insertion/deletion which may alter the size of the result."
replacement size = (stop - start + 1)
ifFalse: [self error: 'Size of replacement doesnt match'].
^self replaceFrom: start to: stop with: replacement startingAt: 1!
----- Method: SequenceableCollection>>replaceFrom:to:with:startingAt: (in category 'accessing') -----
replaceFrom: start to: stop with: replacement startingAt: repStart
"This destructively replaces elements from start to stop in the receiver
starting at index, repStart, in the sequenceable collection,
replacementCollection. Answer the receiver. No range checks are
performed."
| index repOff |
repOff _ repStart - start.
index _ start - 1.
[(index _ index + 1) <= stop]
whileTrue: [self at: index put: (replacement at: repOff + index)]!
----- Method: SequenceableCollection>>reverse (in category 'converting') -----
reverse
^ self reversed!
----- Method: SequenceableCollection>>reverseDo: (in category 'enumerating') -----
reverseDo: aBlock
"Evaluate aBlock with each of the receiver's elements as the argument,
starting with the last element and taking each in sequence up to the
first. For SequenceableCollections, this is the reverse of the enumeration
for do:."
self size to: 1 by: -1 do: [:index | aBlock value: (self at: index)]!
----- Method: SequenceableCollection>>reverseWith:do: (in category 'enumerating') -----
reverseWith: aSequenceableCollection do: aBlock
"Evaluate aBlock with each of the receiver's elements, in reverse order,
along with the
corresponding element, also in reverse order, from
aSequencableCollection. "
self size ~= aSequenceableCollection size ifTrue: [^ self errorNoMatch].
self size
to: 1
by: -1
do: [:index | aBlock value: (self at: index)
value: (aSequenceableCollection at: index)]!
----- Method: SequenceableCollection>>reversed (in category 'converting') -----
reversed
"Answer a copy of the receiver with element order reversed."
"Example: 'frog' reversed"
| n result src |
n _ self size.
result _ self species new: n.
src _ n + 1.
1 to: n do: [:i | result at: i put: (self at: (src _ src - 1))].
^ result
!
----- Method: SequenceableCollection>>second (in category 'accessing') -----
second
"Answer the second element of the receiver.
Raise an error if there are not enough elements."
^ self at: 2!
----- Method: SequenceableCollection>>select: (in category 'enumerating') -----
select: aBlock
"Refer to the comment in Collection|select:."
| aStream |
aStream _ WriteStream on: (self species new: self size).
1 to: self size do:
[:index |
(aBlock value: (self at: index))
ifTrue: [aStream nextPut: (self at: index)]].
^ aStream contents!
----- Method: SequenceableCollection>>seventh (in category 'accessing') -----
seventh
"Answer the seventh element of the receiver.
Raise an error if there are not enough elements."
^ self at: 7!
----- Method: SequenceableCollection>>shallowCopy (in category 'copying') -----
shallowCopy
^self copyFrom: 1 to: self size!
----- Method: SequenceableCollection>>shuffled (in category 'copying') -----
shuffled
^ self shuffledBy: Collection randomForPicking
"Examples:
($A to: $Z) shuffled
"!
----- Method: SequenceableCollection>>shuffledBy: (in category 'shuffling') -----
shuffledBy: aRandom
| copy |
copy _ self shallowCopy.
copy size to: 1 by: -1 do:
[:i | copy swap: i with: ((1 to: i) atRandom: aRandom)].
^ copy!
----- Method: SequenceableCollection>>sixth (in category 'accessing') -----
sixth
"Answer the sixth element of the receiver.
Raise an error if there are not enough elements."
^ self at: 6!
----- Method: SequenceableCollection>>sortBy: (in category 'copying') -----
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)."
^ (self asSortedCollection: aBlock) asOrderedCollection!
----- Method: SequenceableCollection>>swap:with: (in category 'accessing') -----
swap: oneIndex with: anotherIndex
"Move the element at oneIndex to anotherIndex, and vice-versa."
| element |
element _ self at: oneIndex.
self at: oneIndex put: (self at: anotherIndex).
self at: anotherIndex put: element!
----- Method: SequenceableCollection>>third (in category 'accessing') -----
third
"Answer the third element of the receiver.
Raise an error if there are not enough elements."
^ self at: 3!
----- Method: SequenceableCollection>>upTo: (in category 'enumerating') -----
upTo: anObject
"Deprecated. Use copyUpTo:"
^ self copyUpTo: anObject!
----- Method: SequenceableCollection>>with:collect: (in category 'enumerating') -----
with: otherCollection collect: twoArgBlock
"Collect and return the result of evaluating twoArgBlock with corresponding elements from this collection and otherCollection."
| result |
otherCollection size = self size ifFalse: [self error: 'otherCollection must be the same size'].
result _ self species new: self size.
1 to: self size do:
[:index | result at: index put:
(twoArgBlock
value: (self at: index)
value: (otherCollection at: index))].
^ result!
----- Method: SequenceableCollection>>with:do: (in category 'enumerating') -----
with: otherCollection do: twoArgBlock
"Evaluate twoArgBlock with corresponding elements from this collection and otherCollection."
otherCollection size = self size ifFalse: [self error: 'otherCollection must be the same size'].
1 to: self size do:
[:index |
twoArgBlock value: (self at: index)
value: (otherCollection at: index)]!
----- Method: SequenceableCollection>>withIndexCollect: (in category 'enumerating') -----
withIndexCollect: elementAndIndexBlock
"Just like with:collect: except that the iteration index supplies the second argument to the block."
| result |
result _ self species new: self size.
1 to: self size do:
[:index | result at: index put:
(elementAndIndexBlock
value: (self at: index)
value: index)].
^ result!
----- Method: SequenceableCollection>>withIndexDo: (in category 'enumerating') -----
withIndexDo: elementAndIndexBlock
"Just like with:do: except that the iteration index supplies the second argument to the block."
1 to: self size do:
[:index |
elementAndIndexBlock
value: (self at: index)
value: index]!
----- Method: SequenceableCollection>>writeStream (in category 'converting') -----
writeStream
^ WriteStream on: self!
Collection subclass: #Set
instanceVariableNames: 'tally array'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Unordered'!
!Set commentStamp: '<historical>' prior: 0!
I represent a set of objects without duplicates. I can hold anything that responds to
#hash and #=, except for nil. My instances will automatically grow, if necessary,
Note that I rely on #=, not #==. If you want a set using #==, use IdentitySet.
Instance structure:
array An array whose non-nil elements are the elements of the set,
and whose nil elements are empty slots. There is always at least one nil.
In fact I try to keep my "load" at 75% or less so that hashing will work well.
tally The number of elements in the set. The array size is always greater than this.
The core operation is #findElementOrNil:, which either finds the position where an
object is stored in array, if it is present, or finds a suitable position holding nil, if
its argument is not present in array,!
Set subclass: #Dictionary
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Unordered'!
!Dictionary commentStamp: '<historical>' prior: 0!
I represent a set of elements that can be viewed from one of two perspectives: a set of associations, or a container 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. I inherit many operations from Set.!
----- Method: Dictionary class>>newFrom: (in category 'instance creation') -----
newFrom: aDict
"Answer an instance of me containing the same associations as aDict.
Error if any key appears twice."
| newDictionary |
newDictionary _ self new: aDict size.
aDict associationsDo:
[:x |
(newDictionary includesKey: x key)
ifTrue: [self error: 'Duplicate key: ', x key printString]
ifFalse: [newDictionary add: x]].
^ newDictionary
" NewDictionary newFrom: {1->#a. 2->#b. 3->#c}
{1->#a. 2->#b. 3->#c} as: NewDictionary
NewDictionary newFrom: {1->#a. 2->#b. 1->#c}
{1->#a. 2->#b. 1->#c} as: NewDictionary
"!
----- Method: Dictionary class>>newFromPairs: (in category 'instance creation') -----
newFromPairs: anArray
"Answer an instance of me associating (anArray at:i) to (anArray at: i+i)
for each odd i. anArray must have an even number of entries."
| newDictionary |
newDictionary := self new: (anArray size/2).
1 to: (anArray size-1) by: 2 do: [ :i|
newDictionary at: (anArray at: i) put: (anArray at: i+1).
].
^ newDictionary
" Dictionary newFromPairs: {'Red' . Color red . 'Blue' . Color blue . 'Green' . Color green}. "!
----- Method: Dictionary>>= (in category 'comparing') -----
= aDictionary
"Two dictionaries are equal if
(a) they are the same 'kind' of thing.
(b) they have the same set of keys.
(c) for each (common) key, they have the same value"
self == aDictionary ifTrue: [ ^ true ].
(aDictionary isKindOf: Dictionary) ifFalse: [^false].
self size = aDictionary size ifFalse: [^false].
self associationsDo: [:assoc|
(aDictionary at: assoc key ifAbsent: [^false]) = assoc value
ifFalse: [^false]].
^true
!
----- Method: Dictionary>>add: (in category 'adding') -----
add: anAssociation
| index element |
index _ self findElementOrNil: anAssociation key.
element _ array at: index.
element == nil
ifTrue: [self atNewIndex: index put: anAssociation]
ifFalse: [element value: anAssociation value].
^ anAssociation!
----- Method: Dictionary>>addAll: (in category 'adding') -----
addAll: aKeyedCollection
aKeyedCollection == self ifFalse: [
aKeyedCollection keysAndValuesDo: [:key :value |
self at: key put: value]].
^aKeyedCollection!
----- Method: Dictionary>>associationAt: (in category 'accessing') -----
associationAt: key
^ self associationAt: key ifAbsent: [self errorKeyNotFound]!
----- Method: Dictionary>>associationAt:ifAbsent: (in category 'accessing') -----
associationAt: key ifAbsent: aBlock
"Answer the association with the given key.
If key is not found, return the result of evaluating aBlock."
| index assoc |
index _ self findElementOrNil: key.
assoc _ array at: index.
nil == assoc ifTrue: [ ^ aBlock value ].
^ assoc!
----- Method: Dictionary>>associationDeclareAt: (in category 'accessing') -----
associationDeclareAt: aKey
"Return an existing association, or create and return a new one. Needed as a single message by ImageSegment.prepareToBeSaved."
| existing |
^ self associationAt: aKey ifAbsent: [
(Undeclared includesKey: aKey)
ifTrue:
[existing _ Undeclared associationAt: aKey.
Undeclared removeKey: aKey.
self add: existing]
ifFalse:
[self add: aKey -> false]]!
----- Method: Dictionary>>associations (in category 'accessing') -----
associations
"Answer a Collection containing the receiver's associations."
| out |
out _ WriteStream on: (Array new: self size).
self associationsDo: [:value | out nextPut: value].
^ out contents!
----- Method: Dictionary>>associationsDo: (in category 'enumerating') -----
associationsDo: aBlock
"Evaluate aBlock for each of the receiver's elements (key/value
associations)."
super do: aBlock!
----- Method: Dictionary>>associationsSelect: (in category 'enumerating') -----
associationsSelect: aBlock
"Evaluate aBlock with each of my associations as the argument. Collect
into a new dictionary, only those associations for which aBlock evaluates
to true."
| newCollection |
newCollection _ self species new.
self associationsDo:
[:each |
(aBlock value: each) ifTrue: [newCollection add: each]].
^newCollection!
----- Method: Dictionary>>at: (in category 'accessing') -----
at: key
"Answer the value associated with the key."
^ self at: key ifAbsent: [self errorKeyNotFound]!
----- Method: Dictionary>>at:ifAbsent: (in category 'accessing') -----
at: key ifAbsent: aBlock
"Answer the value associated with the key or, if key isn't found,
answer the result of evaluating aBlock."
| assoc |
assoc _ array at: (self findElementOrNil: key).
assoc ifNil: [^ aBlock value].
^ assoc value!
----- Method: Dictionary>>at:ifAbsentPut: (in category 'accessing') -----
at: key ifAbsentPut: aBlock
"Return the value at the given key.
If key is not included in the receiver store the result
of evaluating aBlock as new value."
^ self at: key ifAbsent: [self at: key put: aBlock value]!
----- Method: Dictionary>>at:ifPresent: (in category 'accessing') -----
at: key ifPresent: aBlock
"Lookup the given key in the receiver. If it is present, answer the value of evaluating the given block with the value associated with the key. Otherwise, answer nil."
| v |
v _ self at: key ifAbsent: [^ nil].
^ aBlock value: v
!
----- Method: Dictionary>>at:ifPresentAndInMemory: (in category 'accessing') -----
at: key ifPresentAndInMemory: aBlock
"Lookup the given key in the receiver. If it is present, answer the value of evaluating the given block with the value associated with the key. Otherwise, answer nil."
| v |
v _ self at: key ifAbsent: [^ nil].
v isInMemory ifFalse: [^ nil].
^ aBlock value: v
!
----- Method: Dictionary>>at:put: (in category 'accessing') -----
at: key put: anObject
"Set the value at key to be anObject. If key is not found, create a
new entry for key and set is value to anObject. Answer anObject."
| index assoc |
index _ self findElementOrNil: key.
assoc _ array at: index.
assoc
ifNil: [self atNewIndex: index put: (Association key: key value: anObject)]
ifNotNil: [assoc value: anObject].
^ anObject!
----- Method: Dictionary>>collect: (in category 'enumerating') -----
collect: aBlock
"Evaluate aBlock with each of my values as the argument. Collect the
resulting values into a collection that is like me. Answer with the new
collection."
| newCollection |
newCollection _ OrderedCollection new: self size.
self do: [:each | newCollection add: (aBlock value: each)].
^ newCollection!
----- Method: Dictionary>>copy (in category 'private') -----
copy
"Must copy the associations, or later store will affect both the
original and the copy"
^ self shallowCopy withArray:
(array collect: [:assoc |
assoc ifNil: [nil]
ifNotNil: [Association key: assoc key
value: assoc value]])!
----- Method: Dictionary>>customizeExplorerContents (in category 'accessing') -----
customizeExplorerContents
^ true.
!
----- Method: Dictionary>>declare:from: (in category 'adding') -----
declare: key from: aDictionary
"Add key to the receiver. If key already exists, do nothing. If aDictionary
includes key, then remove it from aDictionary and use its association as
the element of the receiver."
(self includesKey: key) ifTrue: [^ self].
(aDictionary includesKey: key)
ifTrue:
[self add: (aDictionary associationAt: key).
aDictionary removeKey: key]
ifFalse:
[self add: key -> nil]!
----- Method: Dictionary>>do: (in category 'enumerating') -----
do: aBlock
super do: [:assoc | aBlock value: assoc value]!
----- Method: Dictionary>>errorKeyNotFound (in category 'private') -----
errorKeyNotFound
self error: 'key not found'!
----- Method: Dictionary>>errorValueNotFound (in category 'private') -----
errorValueNotFound
self error: 'value not found'!
----- Method: Dictionary>>explorerContentsWithIndexCollect: (in category 'user interface') -----
explorerContentsWithIndexCollect: twoArgBlock
| sortedKeys |
sortedKeys _ self keys asSortedCollection: [:x :y |
((x isString and: [y isString])
or: [x isNumber and: [y isNumber]])
ifTrue: [x < y]
ifFalse: [x class == y class
ifTrue: [x printString < y printString]
ifFalse: [x class name < y class name]]].
^ sortedKeys collect: [:k | twoArgBlock value: (self at: k) value: k].
!
----- Method: Dictionary>>flattenOnStream: (in category 'filter streaming') -----
flattenOnStream:aStream
^aStream writeDictionary:self.
!
----- Method: Dictionary>>hasBindingThatBeginsWith: (in category 'testing') -----
hasBindingThatBeginsWith: aString
"Answer true if the receiver has a key that begins with aString, false otherwise"
self keysDo:[:each |
(each beginsWith: aString)
ifTrue:[^true]].
^false!
----- Method: Dictionary>>includes: (in category 'testing') -----
includes: anObject
self do: [:each | anObject = each ifTrue: [^true]].
^false!
----- Method: Dictionary>>includesAssociation: (in category 'testing') -----
includesAssociation: anAssociation
^ (self
associationAt: anAssociation key
ifAbsent: [ ^ false ]) value = anAssociation value
!
----- Method: Dictionary>>includesIdentity: (in category 'testing') -----
includesIdentity: anObject
"Answer whether anObject is one of the values of the receiver. Contrast #includes: in which there is only an equality check, here there is an identity check"
self do: [:each | anObject == each ifTrue: [^ true]].
^ false!
----- Method: Dictionary>>includesKey: (in category 'testing') -----
includesKey: key
"Answer whether the receiver has a key equal to the argument, key."
self at: key ifAbsent: [^false].
^true!
----- Method: Dictionary>>keyAt: (in category 'private') -----
keyAt: index
"May be overridden by subclasses so that fixCollisions will work"
| assn |
assn _ array at: index.
assn == nil ifTrue: [^ nil]
ifFalse: [^ assn key]!
----- Method: Dictionary>>keyAtIdentityValue: (in category 'accessing') -----
keyAtIdentityValue: value
"Answer the key that is the external name for the argument, value. If
there is none, answer nil.
Note: There can be multiple keys with the same value. Only one is returned."
^self keyAtIdentityValue: value ifAbsent: [self errorValueNotFound]!
----- Method: Dictionary>>keyAtIdentityValue:ifAbsent: (in category 'accessing') -----
keyAtIdentityValue: value ifAbsent: exceptionBlock
"Answer the key that is the external name for the argument, value. If
there is none, answer the result of evaluating exceptionBlock.
Note: There can be multiple keys with the same value. Only one is returned."
self associationsDo:
[:association | value == association value ifTrue: [^association key]].
^exceptionBlock value!
----- Method: Dictionary>>keyAtValue: (in category 'accessing') -----
keyAtValue: value
"Answer the key that is the external name for the argument, value. If
there is none, answer nil."
^self keyAtValue: value ifAbsent: [self errorValueNotFound]!
----- Method: Dictionary>>keyAtValue:ifAbsent: (in category 'accessing') -----
keyAtValue: value ifAbsent: exceptionBlock
"Answer the key that is the external name for the argument, value. If
there is none, answer the result of evaluating exceptionBlock.
: Use =, not ==, so stings like 'this' can be found. Note that MethodDictionary continues to use == so it will be fast."
self associationsDo:
[:association | value = association value ifTrue: [^association key]].
^exceptionBlock value!
----- Method: Dictionary>>keyForIdentity: (in category 'accessing') -----
keyForIdentity: anObject
"If anObject is one of the values of the receive, return its key, else return nil. Contrast #keyAtValue: in which there is only an equality check, here there is an identity check"
self associationsDo: [:assoc | assoc value == anObject ifTrue: [^ assoc key]].
^ nil!
----- Method: Dictionary>>keys (in category 'accessing') -----
keys
"Answer a Set containing the receiver's keys."
| aSet |
aSet _ Set new: self size.
self keysDo: [:key | aSet add: key].
^ aSet!
----- Method: Dictionary>>keysAndValuesDo: (in category 'enumerating') -----
keysAndValuesDo: aBlock
^self associationsDo:[:assoc|
aBlock value: assoc key value: assoc value].!
----- Method: Dictionary>>keysAndValuesRemove: (in category 'removing') -----
keysAndValuesRemove: keyValueBlock
"Removes all entries for which keyValueBlock returns true."
"When removing many items, you must not do it while iterating over the dictionary, since it may be changing. This method takes care of tallying the removals in a first pass, and then performing all the deletions afterward. Many places in the sytem could be simplified by using this method."
| removals |
removals _ OrderedCollection new.
self associationsDo:
[:assoc | (keyValueBlock value: assoc key value: assoc value)
ifTrue: [removals add: assoc key]].
removals do:
[:aKey | self removeKey: aKey]!
----- Method: Dictionary>>keysDo: (in category 'enumerating') -----
keysDo: aBlock
"Evaluate aBlock for each of the receiver's keys."
self associationsDo: [:association | aBlock value: association key]!
----- Method: Dictionary>>keysSortedSafely (in category 'accessing') -----
keysSortedSafely
"Answer a SortedCollection containing the receiver's keys."
| sortedKeys |
sortedKeys _ SortedCollection new: self size.
sortedKeys sortBlock:
[:x :y | "Should really be use <obj, string, num> compareSafely..."
((x isString and: [y isString])
or: [x isNumber and: [y isNumber]])
ifTrue: [x < y]
ifFalse: [x class == y class
ifTrue: [x printString < y printString]
ifFalse: [x class name < y class name]]].
self keysDo: [:each | sortedKeys addLast: each].
^ sortedKeys reSort!
----- Method: Dictionary>>noCheckAdd: (in category 'private') -----
noCheckAdd: anObject
"Must be defined separately for Dictionary because (self findElementOrNil:) expects a key, not an association. 9/7/96 tk"
array at: (self findElementOrNil: anObject key) put: anObject.
tally _ tally + 1!
----- Method: Dictionary>>occurrencesOf: (in category 'testing') -----
occurrencesOf: anObject
"Answer how many of the receiver's elements are equal to anObject."
| count |
count _ 0.
self do: [:each | anObject = each ifTrue: [count _ count + 1]].
^count!
----- Method: Dictionary>>printElementsOn: (in category 'printing') -----
printElementsOn: aStream
aStream nextPut: $(.
self size > 100
ifTrue: [aStream nextPutAll: 'size '.
self size printOn: aStream]
ifFalse: [self keysSortedSafely
do: [:key | aStream print: key;
nextPutAll: '->';
print: (self at: key);
space]].
aStream nextPut: $)!
----- Method: Dictionary>>rehash (in category 'private') -----
rehash
"Smalltalk rehash."
| newSelf |
newSelf _ self species new: self size.
self associationsDo: [:each | newSelf noCheckAdd: each].
array _ newSelf array!
----- Method: Dictionary>>remove: (in category 'removing') -----
remove: anObject
self shouldNotImplement!
----- Method: Dictionary>>remove:ifAbsent: (in category 'removing') -----
remove: anObject ifAbsent: exceptionBlock
self shouldNotImplement!
----- Method: Dictionary>>removeKey: (in category 'removing') -----
removeKey: key
"Remove key from the receiver.
If key is not in the receiver, notify an error."
^ self removeKey: key ifAbsent: [self errorKeyNotFound]!
----- Method: Dictionary>>removeKey:ifAbsent: (in category 'removing') -----
removeKey: key ifAbsent: aBlock
"Remove key (and its associated value) from the receiver. If key is not in
the receiver, answer the result of evaluating aBlock. Otherwise, answer
the value externally named by key."
| index assoc |
index _ self findElementOrNil: key.
assoc _ array at: index.
assoc == nil ifTrue: [ ^ aBlock value ].
array at: index put: nil.
tally _ tally - 1.
self fixCollisionsFrom: index.
^ assoc value!
----- Method: Dictionary>>removeUnreferencedKeys (in category 'removing') -----
removeUnreferencedKeys "Undeclared removeUnreferencedKeys"
^ self unreferencedKeys do: [:key | self removeKey: key].!
----- Method: Dictionary>>scanFor: (in category 'private') -----
scanFor: anObject
"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
| element start finish |
finish _ array size.
start _ (anObject hash \\ finish) + 1.
"Search from (hash mod size) to the end."
start to: finish do:
[:index | ((element _ array at: index) == nil or: [element key = anObject])
ifTrue: [^ index ]].
"Search from 1 to where we started."
1 to: start-1 do:
[:index | ((element _ array at: index) == nil or: [element key = anObject])
ifTrue: [^ index ]].
^ 0 "No match AND no empty slot"!
----- Method: Dictionary>>select: (in category 'enumerating') -----
select: aBlock
"Evaluate aBlock with each of my values as the argument. Collect into a
new dictionary, only those associations for which aBlock evaluates to
true."
| newCollection |
newCollection _ self species new.
self associationsDo:
[:each |
(aBlock value: each value) ifTrue: [newCollection add: each]].
^newCollection!
----- Method: Dictionary>>storeOn: (in category 'printing') -----
storeOn: aStream
| noneYet |
aStream nextPutAll: '(('.
aStream nextPutAll: self class name.
aStream nextPutAll: ' new)'.
noneYet _ true.
self associationsDo:
[:each |
noneYet
ifTrue: [noneYet _ false]
ifFalse: [aStream nextPut: $;].
aStream nextPutAll: ' add: '.
aStream store: each].
noneYet ifFalse: [aStream nextPutAll: '; yourself'].
aStream nextPut: $)!
----- Method: Dictionary>>unreferencedKeys (in category 'removing') -----
unreferencedKeys
"TextConstants unreferencedKeys"
| n |
^'Scanning for references . . .'
displayProgressAt: Sensor cursorPoint
from: 0
to: self size
during:
[:bar |
n := 0.
self keys select:
[:key |
bar value: (n := n + 1).
(self systemNavigation allCallsOn: (self associationAt: key)) isEmpty]]!
----- Method: Dictionary>>valueAtNewKey:put:atIndex:declareFrom: (in category 'private') -----
valueAtNewKey: aKey put: anObject atIndex: index declareFrom: aDictionary
"Support for coordinating class variable and global declarations
with variables that have been put in Undeclared so as to
redirect all references to the undeclared variable."
(aDictionary includesKey: aKey)
ifTrue:
[self atNewIndex: index
put: ((aDictionary associationAt: aKey) value: anObject).
aDictionary removeKey: aKey]
ifFalse:
[self atNewIndex: index put: (Association key: aKey value: anObject)]!
----- Method: Dictionary>>values (in category 'accessing') -----
values
"Answer a Collection containing the receiver's values."
| out |
out _ WriteStream on: (Array new: self size).
self valuesDo: [:value | out nextPut: value].
^ out contents!
----- Method: Dictionary>>valuesDo: (in category 'enumerating') -----
valuesDo: aBlock
"Evaluate aBlock for each of the receiver's values."
self associationsDo: [:association | aBlock value: association value]!
Dictionary subclass: #IdentityDictionary
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Unordered'!
!IdentityDictionary commentStamp: 'ls 06/15/02 22:35' prior: 0!
Like a Dictionary, except that keys are compared with #== instead of #= .
See the comment of IdentitySet for more information.!
----- Method: IdentityDictionary>>fasterKeys (in category 'private') -----
fasterKeys
"This was taking some time in publishing and we didn't really need a Set"
| answer index |
answer _ Array new: self size.
index _ 0.
self keysDo: [:key | answer at: (index _ index + 1) put: key].
^ answer!
----- Method: IdentityDictionary>>keyAtValue:ifAbsent: (in category 'accessing') -----
keyAtValue: value ifAbsent: exceptionBlock
"Answer the key that is the external name for the argument, value. If
there is none, answer the result of evaluating exceptionBlock."
self associationsDo:
[:association | value == association value ifTrue: [^ association key]].
^ exceptionBlock value!
----- Method: IdentityDictionary>>keys (in category 'private') -----
keys
"Answer a Set containing the receiver's keys."
| aSet |
aSet _ IdentitySet new: self size.
self keysDo: [:key | aSet add: key].
^ aSet!
----- Method: IdentityDictionary>>scanFor: (in category 'private') -----
scanFor: anObject
"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
| finish hash start element |
finish _ array size.
finish > 4096
ifTrue: [hash _ anObject identityHash * (finish // 4096)]
ifFalse: [hash _ anObject identityHash].
start _ (hash \\ finish) + 1.
"Search from (hash mod size) to the end."
start to: finish do:
[:index | ((element _ array at: index) == nil or: [element key == anObject])
ifTrue: [^ index ]].
"Search from 1 to where we started."
1 to: start-1 do:
[:index | ((element _ array at: index) == nil or: [element key == anObject])
ifTrue: [^ index ]].
^ 0 "No match AND no empty slot"!
Dictionary subclass: #PluggableDictionary
instanceVariableNames: 'hashBlock equalBlock'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Unordered'!
!PluggableDictionary commentStamp: '<historical>' prior: 0!
Class PluggableDictionary allows the redefinition of hashing and equality by clients. This is in particular useful if the clients know about specific properties of the objects stored in the dictionary. See the class comment of PluggableSet for an example.
Instance variables:
hashBlock <BlockContext> A one argument block used for hashing the elements.
equalBlock <BlockContext> A two argument block used for comparing the elements.
!
----- Method: PluggableDictionary class>>integerDictionary (in category 'instance creation') -----
integerDictionary
^ self new hashBlock: [:integer | integer hash \\ 1064164 * 1009]!
----- Method: PluggableDictionary>>copy (in category 'copying') -----
copy
^super copy postCopyBlocks!
----- Method: PluggableDictionary>>equalBlock (in category 'accessing') -----
equalBlock
"Return the block used for comparing the elements in the receiver."
^equalBlock!
----- Method: PluggableDictionary>>equalBlock: (in category 'accessing') -----
equalBlock: aBlock
"Set a new equality block. The block must accept two arguments and return true if the argumets are considered to be equal, false otherwise"
equalBlock _ aBlock.!
----- Method: PluggableDictionary>>hashBlock (in category 'accessing') -----
hashBlock
"Return the block used for hashing the elements in the receiver."
^hashBlock!
----- Method: PluggableDictionary>>hashBlock: (in category 'accessing') -----
hashBlock: aBlock
"Set a new hash block. The block must accept one argument and must return the hash value of the given argument."
hashBlock _ aBlock.!
----- Method: PluggableDictionary>>keys (in category 'accessing') -----
keys
"Answer a Set containing the receiver's keys."
| aSet |
aSet _ PluggableSet new: self size.
self equalBlock ifNotNil: [aSet equalBlock: self equalBlock fixTemps].
self hashBlock ifNotNil: [aSet hashBlock: self hashBlock fixTemps].
self keysDo: [:key | aSet add: key].
^ aSet!
----- Method: PluggableDictionary>>postCopyBlocks (in category 'copying') -----
postCopyBlocks
hashBlock _ hashBlock copy.
equalBlock _ equalBlock copy.
"Fix temps in case we're referring to outside stuff"
hashBlock ifNotNil: [hashBlock fixTemps].
equalBlock ifNotNil: [equalBlock fixTemps]!
----- Method: PluggableDictionary>>scanFor: (in category 'private') -----
scanFor: anObject
"Scan the key array for the first slot containing either a nil
(indicating
an empty slot) or an element that matches anObject. Answer the index
of that slot or zero if no slot is found. This method will be
overridden
in various subclasses that have different interpretations for matching
elements."
| element start finish |
finish _ array size.
start _ (hashBlock ifNil: [anObject hash]
ifNotNil: [hashBlock value: anObject])
\\ finish + 1.
"Search from (hash mod size) to the end."
start to: finish do: [:index | ((element _ array at: index) == nil or:
[equalBlock ifNil: [element key = anObject]
ifNotNil: [equalBlock value: element key value: anObject]])
ifTrue: [^ index]].
"Search from 1 to where we started."
1 to: start - 1 do: [:index | ((element _ array at: index) == nil or:
[equalBlock ifNil: [element key = anObject]
ifNotNil: [equalBlock value: element key value: anObject]])
ifTrue: [^ index]].
^ 0"No match AND no empty slot"!
Dictionary subclass: #WeakKeyDictionary
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Weak'!
!WeakKeyDictionary commentStamp: '<historical>' prior: 0!
I am a dictionary holding only weakly on my keys. This is a bit dangerous since at any time my keys can go away. Clients are responsible to register my instances by WeakArray such that the appropriate actions can be taken upon loss of any keys.
See WeakRegistry for an example of use.
!
WeakKeyDictionary subclass: #WeakIdentityKeyDictionary
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Weak'!
!WeakIdentityKeyDictionary commentStamp: '<historical>' prior: 0!
This class represents an identity dictionary with weak keys.!
----- Method: WeakIdentityKeyDictionary>>scanFor: (in category 'private') -----
scanFor: anObject
"ar 10/21/2000: The method has been copied to this location to indicate that whenever #scanFor: changes #scanForNil: must be changed in the receiver as well."
"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
| element start finish hash |
finish _ array size.
finish > 4096
ifTrue: [hash _ anObject identityHash * (finish // 4096)]
ifFalse: [hash _ anObject identityHash].
start _ (hash \\ finish) + 1.
"Search from (hash mod size) to the end."
start to: finish do:
[:index | ((element _ array at: index) == nil or: [element key == anObject])
ifTrue: [^ index ]].
"Search from 1 to where we started."
1 to: start-1 do:
[:index | ((element _ array at: index) == nil or: [element key == anObject])
ifTrue: [^ index ]].
^ 0 "No match AND no empty slot"!
----- Method: WeakIdentityKeyDictionary>>scanForNil: (in category 'private') -----
scanForNil: anObject
"Private. Scan the key array for the first slot containing nil (indicating an empty slot). Answer the index of that slot."
| start finish hash |
finish _ array size.
finish > 4096
ifTrue: [hash _ anObject identityHash * (finish // 4096)]
ifFalse: [hash _ anObject identityHash].
start _ (hash \\ array size) + 1.
"Search from (hash mod size) to the end."
start to: finish do:
[:index | (array at: index) == nil ifTrue: [^ index ]].
"Search from 1 to where we started."
1 to: start-1 do:
[:index | (array at: index) == nil ifTrue: [^ index ]].
^ 0 "No match AND no empty slot"!
WeakIdentityKeyDictionary subclass: #WeakKeyToCollectionDictionary
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Weak'!
!WeakKeyToCollectionDictionary commentStamp: '<historical>' prior: 0!
This class represents an identity dictionary with weak keys, whose values are collections.
Keys not in the dictionary are mapped to the empty collection. Conversely, if a collection becomes empty, the mapping can be removed to save time and space. However, because this requires re-hashing, it does not pay to do this to eagerly.!
----- Method: WeakKeyToCollectionDictionary>>finalizeValues (in category 'as yet unclassified') -----
finalizeValues
self rehash!
----- Method: WeakKeyToCollectionDictionary>>rehash (in category 'as yet unclassified') -----
rehash
"Rehash the receiver. Reimplemented to remove nils from the collections
that appear as values, and to entirely remove associations with empty collections
as values."
| oldArray assoc cleanedValue newIndex |
oldArray := array.
array := Array new: oldArray size.
tally := 0.
1 to: array size do: [:i |
assoc := oldArray at: i.
(assoc notNil
and: [(cleanedValue := assoc value copyWithout: nil) notEmpty])
ifTrue: [newIndex := self scanForNil: assoc key.
assoc value: cleanedValue.
self atNewIndex: newIndex put: assoc]]!
----- Method: WeakKeyDictionary>>add: (in category 'adding') -----
add: anAssociation
self at: anAssociation key put: anAssociation value.
^ anAssociation!
----- Method: WeakKeyDictionary>>at:put: (in category 'accessing') -----
at: key put: anObject
"Set the value at key to be anObject. If key is not found, create a new
entry for key and set is value to anObject. Answer anObject."
| index element |
key isNil ifTrue:[^anObject].
index _ self findElementOrNil: key.
element _ array at: index.
element == nil
ifTrue: [self atNewIndex: index put: (WeakKeyAssociation key: key value: anObject)]
ifFalse: [element value: anObject].
^ anObject!
----- Method: WeakKeyDictionary>>finalizeValues (in category 'finalization') -----
finalizeValues
"remove all nil keys and rehash the receiver afterwards"
| assoc |
1 to: array size do:[:i|
assoc _ array at: i.
(assoc notNil and:[assoc key == nil]) ifTrue:[array at: i put: nil].
].
self rehash.!
----- Method: WeakKeyDictionary>>finalizeValues: (in category 'finalization') -----
finalizeValues: finiObjects
"Remove all associations with key == nil and value is in finiObjects.
This method is folded with #rehash for efficiency."
| oldArray assoc newIndex |
oldArray _ array.
array _ Array new: oldArray size.
tally _ 0.
1 to: array size do:[:i|
assoc _ oldArray at: i.
assoc ifNotNil:[
(assoc key == nil and:[finiObjects includes: assoc value]) ifFalse:[
newIndex _ self scanForNil: assoc key.
self atNewIndex: newIndex put: assoc].
].
].!
----- Method: WeakKeyDictionary>>fixCollisionsFrom: (in category 'private') -----
fixCollisionsFrom: oldIndex
"The element at index has been removed and replaced by nil."
self rehash. "Do it the hard way - we may have any number of nil keys and #rehash deals with them"!
----- Method: WeakKeyDictionary>>keysDo: (in category 'enumerating') -----
keysDo: aBlock
"Evaluate aBlock for each of the receiver's keys."
self associationsDo: [:association |
association key ifNotNil:[aBlock value: association key]].!
----- Method: WeakKeyDictionary>>rehash (in category 'private') -----
rehash
"Rehash the receiver. Reimplemented to allow for multiple nil keys"
| oldArray assoc newIndex |
oldArray _ array.
array _ Array new: oldArray size.
tally _ 0.
1 to: array size do:[:i|
assoc _ oldArray at: i.
assoc ifNotNil:[
newIndex _ self scanForNil: assoc key.
self atNewIndex: newIndex put: assoc.
].
].!
----- Method: WeakKeyDictionary>>scanFor: (in category 'private') -----
scanFor: anObject
"ar 10/21/2000: The method has been copied to this location to indicate that whenever #scanFor: changes #scanForNil: must be changed in the receiver as well."
"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
| element start finish |
finish _ array size.
start _ (anObject hash \\ finish) + 1.
"Search from (hash mod size) to the end."
start to: finish do:
[:index | ((element _ array at: index) == nil or: [element key = anObject])
ifTrue: [^ index ]].
"Search from 1 to where we started."
1 to: start-1 do:
[:index | ((element _ array at: index) == nil or: [element key = anObject])
ifTrue: [^ index ]].
^ 0 "No match AND no empty slot"!
----- Method: WeakKeyDictionary>>scanForNil: (in category 'private') -----
scanForNil: anObject
"Private. Scan the key array for the first slot containing nil (indicating an empty slot). Answer the index of that slot."
| start finish |
start _ (anObject hash \\ array size) + 1.
finish _ array size.
"Search from (hash mod size) to the end."
start to: finish do:
[:index | (array at: index) == nil ifTrue: [^ index ]].
"Search from 1 to where we started."
1 to: start-1 do:
[:index | (array at: index) == nil ifTrue: [^ index ]].
^ 0 "No match AND no empty slot"!
Dictionary subclass: #WeakValueDictionary
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Weak'!
!WeakValueDictionary commentStamp: '<historical>' prior: 0!
I am a dictionary holding only weakly on my values. Clients may expect to get a nil value for any object they request.!
----- Method: WeakValueDictionary>>add: (in category 'adding') -----
add: anAssociation
self at: anAssociation key put: anAssociation value.
^ anAssociation!
----- Method: WeakValueDictionary>>at:put: (in category 'accessing') -----
at: key put: anObject
"Set the value at key to be anObject. If key is not found, create a new
entry for key and set is value to anObject. Answer anObject."
| index element |
index _ self findElementOrNil: key.
element _ array at: index.
element == nil
ifTrue: [self atNewIndex: index put: (WeakValueAssociation key: key value: anObject)]
ifFalse: [element value: anObject].
^ anObject!
Set subclass: #IdentitySet
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Unordered'!
!IdentitySet commentStamp: 'sw 1/14/2003 22:35' prior: 0!
The same as a Set, except that items are compared using #== instead of #=.
Almost any class named IdentityFoo is the same as Foo except for the way items are compared. In Foo, #= is used, while in IdentityFoo, #== is used. That is, identity collections will treat items as the same only if they have the same identity.
For example, note that copies of a string are equal:
('abc' copy) = ('abc' copy)
but they are not identitcal:
('abc' copy) == ('abc' copy)
A regular Set will only include equal objects once:
| aSet |
aSet := Set new.
aSet add: 'abc' copy.
aSet add: 'abc' copy.
aSet
An IdentitySet will include multiple equal objects if they are not identical:
| aSet |
aSet := IdentitySet new.
aSet add: 'abc' copy.
aSet add: 'abc' copy.
aSet
!
----- Method: IdentitySet>>asIdentitySet (in category 'converting') -----
asIdentitySet
^self!
----- Method: IdentitySet>>scanFor: (in category 'private') -----
scanFor: anObject
"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
| finish hash start element |
finish _ array size.
finish > 4096
ifTrue: [hash _ anObject identityHash * (finish // 4096)]
ifFalse: [hash _ anObject identityHash].
start _ (hash \\ finish) + 1.
"Search from (hash mod size) to the end."
start to: finish do:
[:index | ((element _ array at: index) == nil or: [element == anObject])
ifTrue: [^ index ]].
"Search from 1 to where we started."
1 to: start-1 do:
[:index | ((element _ array at: index) == nil or: [element == anObject])
ifTrue: [^ index ]].
^ 0 "No match AND no empty slot"!
Set subclass: #KeyedSet
instanceVariableNames: 'keyBlock'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Unordered'!
!KeyedSet commentStamp: '<historical>' prior: 0!
Like Set except a key of every element is used for hashing and searching instead of the element itself. keyBlock gets the key of an element.!
KeyedSet subclass: #KeyedIdentitySet
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Unordered'!
----- Method: KeyedIdentitySet>>scanFor: (in category 'private') -----
scanFor: anObject
"Same as super except change = to ==, and hash to identityHash"
| element start finish |
finish _ array size.
start _ (anObject identityHash \\ finish) + 1.
"Search from (hash mod size) to the end."
start to: finish do:
[:index | ((element _ array at: index) == nil or: [(keyBlock value: element) == anObject])
ifTrue: [^ index ]].
"Search from 1 to where we started."
1 to: start-1 do:
[:index | ((element _ array at: index) == nil or: [(keyBlock value: element) == anObject])
ifTrue: [^ index ]].
^ 0 "No match AND no empty slot"!
----- Method: KeyedSet class>>keyBlock: (in category 'instance creation') -----
keyBlock: oneArgBlock
"Create a new KeySet whose way to access an element's key is by executing oneArgBlock on the element"
^ self new keyBlock: oneArgBlock!
----- Method: KeyedSet>>add: (in category 'adding') -----
add: newObject
"Include newObject as one of the receiver's elements, but only if
not already present. Answer newObject."
| index |
newObject ifNil: [self error: 'Sets cannot meaningfully contain nil as an element'].
index _ self findElementOrNil: (keyBlock value: newObject).
(array at: index) ifNotNil: [^ self errorKeyAlreadyExists: (array at: index)].
self atNewIndex: index put: newObject.
^ newObject!
----- Method: KeyedSet>>addAll: (in category 'adding') -----
addAll: aCollection
"Include all the elements of aCollection as the receiver's elements"
(aCollection respondsTo: #associationsDo:)
ifTrue: [aCollection associationsDo: [:ass | self add: ass]]
ifFalse: [aCollection do: [:each | self add: each]].
^ aCollection!
----- Method: KeyedSet>>at: (in category 'accessing') -----
at: key
"Answer the value associated with the key."
^ self at: key ifAbsent: [self errorKeyNotFound]!
----- Method: KeyedSet>>at:ifAbsent: (in category 'accessing') -----
at: key ifAbsent: aBlock
"Answer the value associated with the key or, if key isn't found,
answer the result of evaluating aBlock."
| obj |
obj _ array at: (self findElementOrNil: key).
obj ifNil: [^ aBlock value].
^ obj!
----- Method: KeyedSet>>at:ifAbsentPut: (in category 'accessing') -----
at: key ifAbsentPut: aBlock
"Answer the value associated with the key or, if key isn't found,
add the result of evaluating aBlock to self"
^ self at: key ifAbsent: [self add: aBlock value]!
----- Method: KeyedSet>>at:ifPresent: (in category 'accessing') -----
at: key ifPresent: aBlock
"Lookup the given key in the receiver. If it is present, answer the value of evaluating the given block with the value associated with the key. Otherwise, answer nil."
| v |
v _ self at: key ifAbsent: [^ nil].
^ aBlock value: v
!
----- Method: KeyedSet>>copy (in category 'copying') -----
copy
^super copy postCopyBlocks!
----- Method: KeyedSet>>errorKeyNotFound (in category 'private') -----
errorKeyNotFound
self error: 'key not found'!
----- Method: KeyedSet>>fixCollisionsFrom: (in category 'private') -----
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"
| length oldIndex newIndex element |
oldIndex _ index.
length _ array size.
[oldIndex = length
ifTrue: [oldIndex _ 1]
ifFalse: [oldIndex _ oldIndex + 1].
(element _ self keyAt: oldIndex) == nil]
whileFalse:
[newIndex _ self findElementOrNil: (keyBlock value: element).
oldIndex = newIndex ifFalse: [self swap: oldIndex with: newIndex]]!
----- Method: KeyedSet>>includes: (in category 'testing') -----
includes: anObject
^ (array at: (self findElementOrNil: (keyBlock value: anObject))) ~~ nil!
----- Method: KeyedSet>>includesKey: (in category 'testing') -----
includesKey: key
^ (array at: (self findElementOrNil: key)) ~~ nil!
----- Method: KeyedSet>>init: (in category 'private') -----
init: n
super init: n.
keyBlock _ [:element | element key].
!
----- Method: KeyedSet>>keyBlock: (in category 'initialize') -----
keyBlock: oneArgBlock
"When evaluated return the key of the argument which will be an element of the set"
keyBlock _ oneArgBlock!
----- Method: KeyedSet>>keys (in category 'accessing') -----
keys
| keys |
keys _ Set new.
self keysDo: [:key | keys add: key].
^ keys!
----- Method: KeyedSet>>keysDo: (in category 'accessing') -----
keysDo: block
self do: [:item | block value: (keyBlock value: item)]!
----- Method: KeyedSet>>keysSorted (in category 'accessing') -----
keysSorted
| keys |
keys _ SortedCollection new.
self do: [:item | keys add: (keyBlock value: item)].
^ keys!
----- Method: KeyedSet>>like:ifAbsent: (in category 'accessing') -----
like: anObject ifAbsent: aBlock
"Answer an object in the receiver that is equal to anObject,
or evaluate the block if not found. Relies heavily on hash properties"
^(array at: (self scanFor: (keyBlock value: anObject)))
ifNil: [ aBlock value ]
ifNotNil: [ :element | element enclosedSetElement ]!
----- Method: KeyedSet>>member: (in category 'adding') -----
member: newObject
"Include newObject as one of the receiver's elements, if already exists just return it"
| index |
newObject ifNil: [self error: 'Sets cannot meaningfully contain nil as an element'].
index _ self findElementOrNil: (keyBlock value: newObject).
(array at: index) ifNotNil: [^ array at: index].
self atNewIndex: index put: newObject.
^ newObject!
----- Method: KeyedSet>>noCheckAdd: (in category 'private') -----
noCheckAdd: anObject
array at: (self findElementOrNil: (keyBlock value: anObject)) put: anObject.
tally _ tally + 1!
----- Method: KeyedSet>>postCopyBlocks (in category 'copying') -----
postCopyBlocks
keyBlock _ keyBlock copy.
"Fix temps in case we're referring to outside stuff"
keyBlock fixTemps.!
----- Method: KeyedSet>>rehash (in category 'private') -----
rehash
| newSelf |
newSelf _ self species new: self size.
newSelf keyBlock: keyBlock.
self do: [:each | newSelf noCheckAdd: each].
array _ newSelf array!
----- Method: KeyedSet>>remove:ifAbsent: (in category 'removing') -----
remove: oldObject ifAbsent: aBlock
| index |
index _ self findElementOrNil: (keyBlock value: oldObject).
(array at: index) == nil ifTrue: [ ^ aBlock value ].
array at: index put: nil.
tally _ tally - 1.
self fixCollisionsFrom: index.
^ oldObject!
----- Method: KeyedSet>>removeKey: (in category 'removing') -----
removeKey: key
^ self removeKey: key ifAbsent: [self errorKeyNotFound]!
----- Method: KeyedSet>>removeKey:ifAbsent: (in category 'removing') -----
removeKey: key ifAbsent: aBlock
| index obj |
index _ self findElementOrNil: key.
(obj _ array at: index) == nil ifTrue: [ ^ aBlock value ].
array at: index put: nil.
tally _ tally - 1.
self fixCollisionsFrom: index.
^ obj!
----- Method: KeyedSet>>scanFor: (in category 'private') -----
scanFor: anObject
"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
| element start finish |
finish _ array size.
start _ (anObject hash \\ finish) + 1.
"Search from (hash mod size) to the end."
start to: finish do:
[:index | ((element _ array at: index) == nil or: [(keyBlock value: element) = anObject])
ifTrue: [^ index ]].
"Search from 1 to where we started."
1 to: start-1 do:
[:index | ((element _ array at: index) == nil or: [(keyBlock value: element) = anObject])
ifTrue: [^ index ]].
^ 0 "No match AND no empty slot"!
Set subclass: #PluggableSet
instanceVariableNames: 'hashBlock equalBlock'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Unordered'!
!PluggableSet commentStamp: '<historical>' prior: 0!
PluggableSets allow the redefinition of hashing and equality by clients. This is in particular useful if the clients know about specific properties of the objects stored in the set which in turn can heavily improve the performance of sets and dictionaries.
Instance variables:
hashBlock <BlockContext> A one argument block used for hashing the elements.
equalBlock <BlockContext> A two argument block used for comparing the elements.
Example: Adding 1000 integer points in the range (0 at 0) to: (100 at 100) to a set.
| rnd set max pt |
set _ Set new: 1000.
rnd _ Random new.
max _ 100.
Time millisecondsToRun:[
1 to: 1000 do:[:i|
pt _ (rnd next * max) truncated @ (rnd next * max) truncated.
set add: pt.
].
].
The above is way slow since the default hashing function of points leads to an awful lot of collisions in the set. And now the same, with a somewhat different hash function:
| rnd set max pt |
set _ PluggableSet new: 1000.
set hashBlock:[:item| (item x bitShift: 16) + item y].
rnd _ Random new.
max _ 100.
Time millisecondsToRun:[
1 to: 1000 do:[:i|
pt _ (rnd next * max) truncated @ (rnd next * max) truncated.
set add: pt.
].
].
!
----- Method: PluggableSet class>>integerSet (in category 'instance creation') -----
integerSet
^self new hashBlock: [:integer | integer hash \\ 1064164 * 1009]!
----- Method: PluggableSet>>copy (in category 'copying') -----
copy
^super copy postCopyBlocks!
----- Method: PluggableSet>>equalBlock (in category 'accessing') -----
equalBlock
"Return the block used for comparing the elements in the receiver."
^equalBlock!
----- Method: PluggableSet>>equalBlock: (in category 'accessing') -----
equalBlock: aBlock
"Set a new equality block. The block must accept two arguments and return true if the argumets are considered equal, false otherwise"
equalBlock _ aBlock.!
----- Method: PluggableSet>>hashBlock (in category 'accessing') -----
hashBlock
"Return the block used for hashing the elements in the receiver."
^hashBlock!
----- Method: PluggableSet>>hashBlock: (in category 'accessing') -----
hashBlock: aBlock
"Set a new hash block. The block must accept one argument and return the hash value of the given argument."
hashBlock _ aBlock.!
----- Method: PluggableSet>>postCopyBlocks (in category 'copying') -----
postCopyBlocks
hashBlock _ hashBlock copy.
equalBlock _ equalBlock copy.
"Fix temps in case we're referring to outside stuff"
hashBlock ifNotNil: [hashBlock fixTemps].
equalBlock ifNotNil: [equalBlock fixTemps]!
----- Method: PluggableSet>>scanFor: (in category 'private') -----
scanFor: anObject
"Scan the key array for the first slot containing either a nil
(indicating
an empty slot) or an element that matches anObject. Answer the index
of that slot or zero if no slot is found. This method will be
overridden
in various subclasses that have different interpretations for matching
elements."
| element start finish |
finish _ array size.
start _ (hashBlock ifNil: [anObject hash]
ifNotNil: [hashBlock value: anObject])
\\ finish + 1.
"Search from (hash mod size) to the end."
start to: finish do: [:index | ((element _ array at: index) == nil or:
[equalBlock ifNil: [element = anObject]
ifNotNil: [equalBlock value: element value: anObject]])
ifTrue: [^ index]].
"Search from 1 to where we started."
1 to: start - 1 do: [:index | ((element _ array at: index) == nil or:
[equalBlock ifNil: [element = anObject]
ifNotNil: [equalBlock value: element value: anObject]])
ifTrue: [^ index]].
^ 0"No match AND no empty slot"!
----- Method: Set class>>new (in category 'instance creation') -----
new
^ self new: 4!
----- Method: Set class>>new: (in category 'instance creation') -----
new: nElements
"Create a Set large enough to hold nElements without growing"
^ super basicNew init: (self sizeFor: nElements)!
----- Method: Set class>>newFrom: (in category 'instance creation') -----
newFrom: aCollection
"Answer an instance of me containing the same elements as aCollection."
| newCollection |
newCollection _ self new: aCollection size.
newCollection addAll: aCollection.
^ newCollection
"
Set newFrom: {1. 2. 3}
{1. 2. 3} as: Set
"!
----- Method: Set class>>quickRehashAllSets (in category 'initialization') -----
quickRehashAllSets "Set rehashAllSets"
| insts |
self withAllSubclassesDo:
[:c |
insts _ c allInstances.
(insts isEmpty or: [c = MethodDictionary]) ifFalse:
['Rehashing instances of ' , c name
displayProgressAt: Sensor cursorPoint
from: 1 to: insts size
during: [:bar | 1 to: insts size do: [:x | bar value: x. (insts at: x) rehash]]
]
]!
----- Method: Set class>>rehashAllSets (in category 'initialization') -----
rehashAllSets "Set rehashAllSets"
| insts |
self withAllSubclassesDo:
[:c |
insts _ c allInstances.
insts isEmpty ifFalse:
['Rehashing instances of ' , c name
displayProgressAt: Sensor cursorPoint
from: 1 to: insts size
during: [:bar | 1 to: insts size do: [:x | bar value: x. (insts at: x) rehash]]
]
]!
----- Method: Set class>>sizeFor: (in category 'instance creation') -----
sizeFor: nElements
"Large enough size to hold nElements with some slop (see fullCheck)"
nElements <= 0 ifTrue: [^ 1].
^ nElements+1*4//3!
----- Method: Set>>= (in category 'comparing') -----
= aSet
self == aSet ifTrue: [^ true]. "stop recursion"
(aSet isKindOf: Set) ifFalse: [^ false].
self size = aSet size ifFalse: [^ false].
self do: [:each | (aSet includes: each) ifFalse: [^ false]].
^ true!
----- Method: Set>>add: (in category 'adding') -----
add: newObject
"Include newObject as one of the receiver's elements, but only if
not already present. Answer newObject."
| index |
newObject ifNil: [self error: 'Sets cannot meaningfully contain nil as an element'].
index _ self findElementOrNil: newObject.
(array at: index) ifNil: [self atNewIndex: index put: newObject].
^ newObject!
----- Method: Set>>add:withOccurrences: (in category 'adding') -----
add: newObject withOccurrences: anInteger
^ self add: newObject!
----- Method: Set>>array (in category 'private') -----
array
^ array!
----- Method: Set>>asSet (in category 'converting') -----
asSet
^self!
----- Method: Set>>atNewIndex:put: (in category 'private') -----
atNewIndex: index put: anObject
array at: index put: anObject.
tally _ tally + 1.
self fullCheck!
----- Method: Set>>atRandom: (in category 'accessing') -----
atRandom: aGenerator
"Answer a random element of the receiver. Uses aGenerator which
should be kept by the user in a variable and used 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."
| ind |
self emptyCheck.
ind _ aGenerator nextInt: array size.
ind to: array size do:[:i|
(array at: i) == nil ifFalse:[^array at: i]].
1 to: ind do:[:i|
(array at: i) == nil ifFalse:[^array at: i]].
self errorEmptyCollection.!
----- Method: Set>>capacity (in category 'accessing') -----
capacity
"Answer the current capacity of the receiver."
^ array size!
----- Method: Set>>collect: (in category 'enumerating') -----
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
the new collection."
| newSet |
newSet _ Set new: self size.
array do: [:each | each ifNotNil: [newSet add: (aBlock value: each)]].
^ newSet!
----- Method: Set>>comeFullyUpOnReload: (in category 'objects from disk') -----
comeFullyUpOnReload: smartRefStream
"Symbols have new hashes in this image."
self rehash.
"^ self"
!
----- Method: Set>>copy (in category 'copying') -----
copy
^ self shallowCopy withArray: array shallowCopy!
----- Method: Set>>copyWithout: (in category 'copying') -----
copyWithout: oldElement
"Answer a copy of the receiver that does not contain any
elements equal to oldElement."
^ self copy
remove: oldElement ifAbsent: [];
yourself!
----- Method: Set>>do: (in category 'enumerating') -----
do: aBlock
tally = 0 ifTrue: [^ self].
1 to: array size do:
[:index |
| each |
(each _ array at: index) ifNotNil: [aBlock value: each]]!
----- Method: Set>>doWithIndex: (in category 'enumerating') -----
doWithIndex: aBlock2
"Support Set enumeration with a counter, even though not ordered"
| index |
index _ 0.
self do: [:item | aBlock2 value: item value: (index _ index+1)]!
----- Method: Set>>findElementOrNil: (in category 'private') -----
findElementOrNil: anObject
"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."
| index |
index _ self scanFor: anObject.
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!!'.!
----- Method: Set>>fixCollisionsFrom: (in category 'private') -----
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"
| length oldIndex newIndex element |
oldIndex _ index.
length _ array size.
[oldIndex = length
ifTrue: [oldIndex _ 1]
ifFalse: [oldIndex _ oldIndex + 1].
(element _ self keyAt: oldIndex) == nil]
whileFalse:
[newIndex _ self findElementOrNil: element.
oldIndex = newIndex ifFalse: [self swap: oldIndex with: newIndex]]!
----- Method: Set>>fullCheck (in category 'private') -----
fullCheck
"Keep array at least 1/4 free for decent hash behavior"
array size - tally < (array size // 4 max: 1)
ifTrue: [self grow]!
----- Method: Set>>grow (in category 'private') -----
grow
"Grow the elements array and reinsert the old elements"
| oldElements |
oldElements _ array.
array _ Array new: array size + self growSize.
tally _ 0.
oldElements do:
[:each | each == nil ifFalse: [self noCheckAdd: each]]!
----- Method: Set>>growSize (in category 'private') -----
growSize
^ array size max: 2!
----- Method: Set>>includes: (in category 'testing') -----
includes: anObject
^ (array at: (self findElementOrNil: anObject)) ~~ nil!
----- Method: Set>>init: (in category 'private') -----
init: n
"Initialize array to an array size of n"
array _ Array new: n.
tally _ 0!
----- Method: Set>>keyAt: (in category 'private') -----
keyAt: index
"May be overridden by subclasses so that fixCollisions will work"
^ array at: index!
----- Method: Set>>like: (in category 'accessing') -----
like: anObject
"Answer an object in the receiver that is equal to anObject,
nil if no such object is found. Relies heavily on hash properties"
| index |
^(index _ self scanFor: anObject) = 0
ifFalse: [array at: index]!
----- Method: Set>>like:ifAbsent: (in category 'accessing') -----
like: anObject ifAbsent: aBlock
"Answer an object in the receiver that is equal to anObject,
or evaluate the block if not found. Relies heavily on hash properties"
^(array at: (self scanFor: anObject))
ifNil: [ aBlock value ]
ifNotNil: [ :element | element enclosedSetElement ]!
----- Method: Set>>noCheckAdd: (in category 'private') -----
noCheckAdd: anObject
array at: (self findElementOrNil: anObject) put: anObject.
tally _ tally + 1!
----- Method: Set>>occurrencesOf: (in category 'testing') -----
occurrencesOf: anObject
^ (self includes: anObject) ifTrue: [1] ifFalse: [0]!
----- Method: Set>>rehash (in category 'private') -----
rehash
| newSelf |
newSelf _ self species new: self size.
self do: [:each | newSelf noCheckAdd: each].
array _ newSelf array!
----- Method: Set>>remove:ifAbsent: (in category 'removing') -----
remove: oldObject ifAbsent: aBlock
| index |
index _ self findElementOrNil: oldObject.
(array at: index) == nil ifTrue: [ ^ aBlock value ].
array at: index put: nil.
tally _ tally - 1.
self fixCollisionsFrom: index.
^ oldObject!
----- Method: Set>>scanFor: (in category 'private') -----
scanFor: anObject
"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
| element start finish |
finish _ array size.
start _ (anObject hash \\ finish) + 1.
"Search from (hash mod size) to the end."
start to: finish do:
[:index | ((element _ array at: index) == nil or: [element = anObject])
ifTrue: [^ index ]].
"Search from 1 to where we started."
1 to: start-1 do:
[:index | ((element _ array at: index) == nil or: [element = anObject])
ifTrue: [^ index ]].
^ 0 "No match AND no empty slot"!
----- Method: Set>>size (in category 'accessing') -----
size
^ tally!
----- Method: Set>>someElement (in category 'accessing') -----
someElement
"Deprecated. Use anyOne."
^ self anyOne!
----- Method: Set>>swap:with: (in category 'private') -----
swap: oneIndex with: otherIndex
"May be overridden by subclasses so that fixCollisions will work"
array swap: oneIndex with: otherIndex
!
----- Method: Set>>union: (in category 'enumerating') -----
union: aCollection
"Answer the set theoretic union of the receiver and aCollection, using the receiver's notion of equality and not side effecting the receiver at all."
^ self copy addAll: aCollection; yourself
!
----- Method: Set>>withArray: (in category 'private') -----
withArray: anArray
"private -- for use only in copy"
array _ anArray!
Set subclass: #WeakSet
instanceVariableNames: 'flag'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Weak'!
----- Method: WeakSet>>add: (in category 'adding') -----
add: newObject
"Include newObject as one of the receiver's elements, but only if
not already present. Answer newObject"
| index |
newObject ifNil: [self error: 'Sets cannot meaningfully contain nil as an element'].
index _ self findElementOrNil: newObject.
((array at: index) == flag or: [(array at: index) isNil])
ifTrue: [self atNewIndex: index put: newObject].
^newObject!
----- Method: WeakSet>>collect: (in category 'enumerating') -----
collect: aBlock
| each newSet |
newSet _ self species new: self size.
tally = 0 ifTrue: [^newSet ].
1 to: array size do:
[:index |
((each _ array at: index) == nil or: [each == flag])
ifFalse: [newSet add: (aBlock value: each)]
].
^newSet!
----- Method: WeakSet>>do: (in category 'enumerating') -----
do: aBlock
| each |
tally = 0 ifTrue: [^self].
1 to: array size do:
[:index |
((each _ array at: index) == nil or: [each == flag])
ifFalse: [aBlock value: each]
]!
----- Method: WeakSet>>do:after: (in category 'public') -----
do: aBlock after: anElement
| each startIndex |
tally = 0 ifTrue: [^self].
startIndex _ anElement ifNil: [1] ifNotNil:
[self findElementOrNil: anElement].
startIndex + 1 to: array size do:
[:index |
((each _ array at: index) == nil or: [each == flag])
ifFalse: [aBlock value: each]
]!
----- Method: WeakSet>>fixCollisionsFrom: (in category 'private') -----
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"
| length oldIndex newIndex element |
oldIndex _ index.
length _ array size.
[oldIndex = length
ifTrue: [oldIndex _ 1]
ifFalse: [oldIndex _ oldIndex + 1].
(element _ self keyAt: oldIndex) == flag]
whileFalse:
[newIndex _ self findElementOrNil: element.
oldIndex = newIndex ifFalse: [self swap: oldIndex with: newIndex]]!
----- Method: WeakSet>>grow (in category 'private') -----
grow
"Grow the elements array and reinsert the old elements"
self growTo: array size + self growSize!
----- Method: WeakSet>>growTo: (in category 'private') -----
growTo: anInteger
"Grow the elements array and reinsert the old elements"
| oldElements |
oldElements _ array.
array _ WeakArray new: anInteger.
array atAllPut: flag.
tally _ 0.
oldElements do:
[:each | (each == flag or: [each == nil]) ifFalse: [self noCheckAdd: each]]!
----- Method: WeakSet>>includes: (in category 'testing') -----
includes: anObject
^(array at: (self findElementOrNil: anObject)) ~~ flag!
----- Method: WeakSet>>init: (in category 'private') -----
init: n
"Initialize array to an array size of n"
flag _ Object new.
array _ WeakArray new: n.
array atAllPut: flag.
tally _ 0!
----- Method: WeakSet>>like: (in category 'accessing') -----
like: anObject
"Answer an object in the receiver that is equal to anObject,
nil if no such object is found. Relies heavily on hash properties"
| index element |
^(index _ self scanFor: anObject) = 0
ifFalse: [(element _ array at: index) == flag ifFalse: [element]]!
----- Method: WeakSet>>like:ifAbsent: (in category 'accessing') -----
like: anObject ifAbsent: aBlock
"Answer an object in the receiver that is equal to anObject,
or evaluate the block if not found. Relies heavily on hash properties"
| element |
((element := array at: (self scanFor: anObject)) == flag or: [ element == nil ])
ifTrue: [ ^aBlock value ]
ifFalse: [ ^element enclosedSetElement ]!
----- Method: WeakSet>>printElementsOn: (in category 'public') -----
printElementsOn: aStream
| oldPos |
aStream nextPut: $(.
oldPos _ aStream position.
self do: [:element | aStream print: element; space].
aStream position > oldPos ifTrue: [aStream skip: -1 "remove the extra space"].
aStream nextPut: $)!
----- Method: WeakSet>>rehash (in category 'private') -----
rehash
self growTo: array size!
----- Method: WeakSet>>remove:ifAbsent: (in category 'removing') -----
remove: oldObject ifAbsent: aBlock
| index |
index _ self findElementOrNil: oldObject.
(array at: index) == flag ifTrue: [ ^ aBlock value ].
array at: index put: flag.
tally _ tally - 1.
self fixCollisionsFrom: index.
^oldObject!
----- Method: WeakSet>>scanFor: (in category 'private') -----
scanFor: anObject
"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements"
| element start finish |
finish _ array size.
start _ (anObject hash \\ finish) + 1.
"Search from (hash mod size) to the end."
start to: finish do:
[:index | ((element _ array at: index) == flag or: [element = anObject])
ifTrue: [^ index ]].
"Search from 1 to where we started."
1 to: start-1 do:
[:index | ((element _ array at: index) == flag or: [element = anObject])
ifTrue: [^ index ]].
^ 0 "No match AND no empty slot"!
----- Method: WeakSet>>scanForLoadedSymbol: (in category 'private') -----
scanForLoadedSymbol: anObject
"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements"
| element start finish |
start _ (anObject hash \\ array size) + 1.
finish _ array size.
"Search from (hash mod size) to the end."
start to: finish do:
[:index | ((element _ array at: index) == flag or: [element asString = anObject asString])
ifTrue: [^ index ]].
"Search from 1 to where we started."
1 to: start-1 do:
[:index | ((element _ array at: index) == flag or: [element asString = anObject asString])
ifTrue: [^ index ]].
^ 0 "No match AND no empty slot"!
----- Method: WeakSet>>size (in category 'accessing') -----
size
"Careful!! Answer the maximum amount
of elements in the receiver, not the
exact amount"
^tally!
----- Method: WeakSet>>slowSize (in category 'public') -----
slowSize
"Careful!! Answer the maximum amount
of elements in the receiver, not the
exact amount"
tally _ array inject: 0 into:
[:total :each | (each == nil or: [each == flag])
ifTrue: [total] ifFalse: [total + 1]].
^tally!
Collection subclass: #SkipList
instanceVariableNames: 'sortBlock pointers numElements level splice'
classVariableNames: 'Rand'
poolDictionaries: ''
category: 'Collections-SkipLists'!
!SkipList commentStamp: 'KLC 2/26/2004 12:04' prior: 0!
>From "Skip Lists: A Probabilistic Alternative to Balanced Trees" by William Pugh ( http://epaperpress.com/sortsearch/download/skiplist.pdf ):
"Skip lists are a data structure that can be used in place of balanced trees. Skip lists use probabilistic balancing rather than strictly enforcing balancing and as a result the algorithms for insertion and deletion in skip lists are much simpler and significantly faster than equivalent algorithms for balanced trees."
Notes:
The elements of the skip list must implement #< or you must provide a sort block.
!
SkipList subclass: #IdentitySkipList
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-SkipLists'!
!IdentitySkipList commentStamp: '<historical>' prior: 0!
Like a SkipList, except that elements are compared with #== instead of #= .
See the comment of IdentitySet for more information.
!
----- Method: IdentitySkipList>>is:equalTo: (in category 'element comparison') -----
is: element1 equalTo: element2
^ element1 == element2!
----- Method: SkipList class>>maxLevel: (in category 'instance creation') -----
maxLevel: maxLevel
"
SkipList maxLevel: 5
"
^ super new initialize: maxLevel!
----- Method: SkipList class>>maxLevel:sortBlock: (in category 'instance creation') -----
maxLevel: anInteger sortBlock: aBlock
^ (self maxLevel: anInteger) sortBlock: aBlock!
----- Method: SkipList class>>new (in category 'instance creation') -----
new
"
SkipList new
"
^ super new initialize: 10!
----- Method: SkipList class>>new: (in category 'instance creation') -----
new: anInteger
^ self maxLevel: (anInteger log: 2) ceiling!
----- Method: SkipList class>>new:sortBlock: (in category 'instance creation') -----
new: anInteger sortBlock: aBlock
^ (self new: anInteger) sortBlock: aBlock!
----- Method: SkipList class>>newFrom: (in category 'instance creation') -----
newFrom: aCollection
| skipList |
skipList _ self new: aCollection size.
skipList addAll: aCollection.
^ skipList!
----- Method: SkipList class>>sortBlock: (in category 'instance creation') -----
sortBlock: aBlock
^ self new sortBlock: aBlock!
----- Method: SkipList>>add: (in category 'adding') -----
add: element
self add: element ifPresent: nil.
^ element!
----- Method: SkipList>>add:ifPresent: (in category 'adding') -----
add: element ifPresent: aBlock
| node lvl s |
node _ self search: element updating: splice.
node ifNotNil: [aBlock ifNotNil: [^ aBlock value: node]].
lvl _ self randomLevel.
node _ SkipListNode on: element level: lvl.
level + 1 to: lvl do: [:i | splice at: i put: self].
1 to: lvl do: [:i |
s _ splice at: i.
node atForward: i put: (s forward: i).
s atForward: i put: node].
numElements _ numElements + 1.
splice atAllPut: nil.
^ element
!
----- Method: SkipList>>atForward:put: (in category 'private') -----
atForward: i put: node
level _ node
ifNil: [pointers findLast: [:n | n notNil]]
ifNotNil: [level max: i].
^ pointers at: i put: node!
----- Method: SkipList>>do: (in category 'enumerating') -----
do: aBlock
self nodesDo: [:node | aBlock value: node object]!
----- Method: SkipList>>forward: (in category 'private') -----
forward: i
^ pointers at: i!
----- Method: SkipList>>includes: (in category 'testing') -----
includes: element
^ (self search: element updating: nil) notNil!
----- Method: SkipList>>initialize: (in category 'initialization') -----
initialize: maxLevel
pointers _ Array new: maxLevel.
splice _ Array new: maxLevel.
numElements _ 0.
level _ 0.
Rand ifNil: [Rand _ Random new]!
----- Method: SkipList>>is:before: (in category 'private') -----
is: node before: element
| object |
node ifNil: [^ false].
object _ node object.
^ sortBlock
ifNil: [object < element]
ifNotNil: [(self is: object equalTo: element) ifTrue: [^ false].
sortBlock value: object value: element]!
----- Method: SkipList>>is:equalTo: (in category 'element comparison') -----
is: element1 equalTo: element2
^ element1 = element2!
----- Method: SkipList>>is:theNodeFor: (in category 'private') -----
is: node theNodeFor: element
node ifNil: [^ false].
node == self ifTrue: [^ false].
^ self is: node object equalTo: element!
----- Method: SkipList>>isEmpty (in category 'testing') -----
isEmpty
^ numElements = 0!
----- Method: SkipList>>level (in category 'accessing') -----
level
^ level!
----- Method: SkipList>>maxLevel (in category 'accessing') -----
maxLevel
^ pointers size!
----- Method: SkipList>>maxLevel: (in category 'accessing') -----
maxLevel: n
| newLevel oldPointers |
newLevel _ n max: level.
oldPointers _ pointers.
pointers _ Array new: newLevel.
splice _ Array new: newLevel.
1 to: level do: [:i | pointers at: i put: (oldPointers at: i)]
!
----- Method: SkipList>>next (in category 'private') -----
next
^ pointers first!
----- Method: SkipList>>nodesDo: (in category 'node enumeration') -----
nodesDo: aBlock
| node |
node _ pointers first.
[node notNil]
whileTrue:
[aBlock value: node.
node _ node next]!
----- Method: SkipList>>randomLevel (in category 'private') -----
randomLevel
| p answer max |
p _ 0.5.
answer _ 1.
max _ self maxLevel.
[Rand next < p and: [answer < max]]
whileTrue: [answer _ answer + 1].
^ answer!
----- Method: SkipList>>remove: (in category 'removing') -----
remove: element
^ self remove: element ifAbsent: [self errorNotFound: element]!
----- Method: SkipList>>remove:ifAbsent: (in category 'removing') -----
remove: element ifAbsent: aBlock
| node i s |
node _ self search: element updating: splice.
node ifNil: [^ aBlock value].
i _ 1.
[s _ splice at: i.
i <= level and: [(s forward: i) == node]]
whileTrue:
[s atForward: i put: (node forward: i).
i _ i + 1].
numElements _ numElements - 1.
splice atAllPut: nil.
^ node object
!
----- Method: SkipList>>removeAll (in category 'removing') -----
removeAll
pointers atAllPut: nil.
splice atAllPut: nil.
numElements _ 0.
level _ 0.!
----- Method: SkipList>>search:updating: (in category 'private') -----
search: element updating: array
| node forward |
node _ self.
level to: 1 by: -1 do: [:i |
[forward _ node forward: i.
self is: forward before: element] whileTrue: [node _ forward].
"At this point: node < element <= forward"
array ifNotNil: [array at: i put: node]].
node _ node next.
^ (self is: node theNodeFor: element) ifTrue: [node]!
----- Method: SkipList>>size (in category 'accessing') -----
size
^ numElements!
----- Method: SkipList>>sortBlock (in category 'accessing') -----
sortBlock
^ sortBlock!
----- Method: SkipList>>sortBlock: (in category 'accessing') -----
sortBlock: aBlock
sortBlock _ aBlock!
Collection subclass: #WeakRegistry
instanceVariableNames: 'valueDictionary accessLock'
classVariableNames: 'Default'
poolDictionaries: ''
category: 'Collections-Weak'!
!WeakRegistry commentStamp: '<historical>' prior: 0!
I am a registry for objects needing finalization. When an object is added the object as well as its executor is stored. When the object is garbage collected, the executor can take the appropriate action for any resources associated with the object.
See also:
Object executor
Object actAsExecutor
Object finalize
!
----- Method: WeakRegistry class>>default (in category 'accessing') -----
default
^Default ifNil:[Default := self new]!
----- Method: WeakRegistry class>>new (in category 'instance creation') -----
new
^self new: 5!
----- Method: WeakRegistry class>>new: (in category 'instance creation') -----
new: n
| registry |
registry := super new initialize: n.
WeakArray addWeakDependent: registry.
^registry!
----- Method: WeakRegistry>>add: (in category 'adding') -----
add: anObject
"Add anObject to the receiver. Store the object as well as the associated executor."
| executor |
executor := anObject executor.
self protected:[
valueDictionary at: anObject put: executor.
].
^anObject!
----- Method: WeakRegistry>>add:executor: (in category 'adding') -----
add: anObject executor: anExecutor
"Add anObject to the receiver. Store the object as well as the associated executor."
self protected:[
valueDictionary at: anObject put: anExecutor.
].
^anObject!
----- Method: WeakRegistry>>do: (in category 'enumerating') -----
do: aBlock
^self protected:[
valueDictionary keysDo: aBlock.
].
!
----- Method: WeakRegistry>>finalizeValues (in category 'finalization') -----
finalizeValues
"Some of our elements may have gone away. Look for those and activate the associated executors."
| finiObjects |
finiObjects := nil.
"First collect the objects."
self protected:[
valueDictionary associationsDo:[:assoc|
assoc key isNil ifTrue:[
finiObjects isNil
ifTrue:[finiObjects := OrderedCollection with: assoc value]
ifFalse:[finiObjects add: assoc value]]
].
finiObjects isNil ifFalse:[valueDictionary finalizeValues: finiObjects asArray].
].
"Then do the finalization"
finiObjects isNil ifTrue:[^self].
finiObjects do:[:each| each finalize].
!
----- Method: WeakRegistry>>initialize: (in category 'initialize') -----
initialize: n
valueDictionary := WeakKeyDictionary new: n.
accessLock := Semaphore forMutualExclusion.!
----- Method: WeakRegistry>>keys (in category 'accessing') -----
keys
^self protected:[
Array streamContents:[:s| valueDictionary keysDo:[:key| s nextPut: key]]].!
----- Method: WeakRegistry>>printElementsOn: (in category 'printing') -----
printElementsOn: aStream
aStream nextPut: $(.
accessLock
ifNil: [self do: [:element | aStream print: element; space]]
ifNotNil: [aStream nextPutAll: '<this WeakRegistry is locked>; space'].
self isEmpty ifFalse: [aStream skip: -1].
aStream nextPut: $)!
----- Method: WeakRegistry>>protected: (in category 'private') -----
protected: aBlock
"Execute aBlock protected by the accessLock"
^accessLock isNil
ifTrue:[aBlock value]
ifFalse:[accessLock critical: aBlock ifError:[:msg :rcvr| rcvr error: msg]]!
----- Method: WeakRegistry>>remove:ifAbsent: (in category 'removing') -----
remove: oldObject ifAbsent: exceptionBlock
"Remove oldObject as one of the receiver's elements."
| removedObject |
oldObject isNil ifTrue:[^oldObject].
self protected:[
removedObject := valueDictionary removeKey: oldObject ifAbsent:[nil].
].
^removedObject isNil
ifTrue:[exceptionBlock value]
ifFalse:[removedObject].
!
----- Method: WeakRegistry>>size (in category 'accessing') -----
size
^ self protected: [valueDictionary size]!
----- Method: WeakRegistry>>species (in category 'private') -----
species
^Set!
Object subclass: #Link
instanceVariableNames: 'nextLink'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Support'!
!Link commentStamp: '<historical>' prior: 0!
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.!
----- Method: Link class>>nextLink: (in category 'instance creation') -----
nextLink: aLink
"Answer an instance of me referring to the argument, aLink."
^self new nextLink: aLink; yourself!
----- Method: Link>>nextLink (in category 'accessing') -----
nextLink
"Answer the link to which the receiver points."
^nextLink!
----- Method: Link>>nextLink: (in category 'accessing') -----
nextLink: aLink
"Store the argument, aLink, as the link to which the receiver refers.
Answer aLink."
^nextLink _ aLink!
Object subclass: #MimeConverter
instanceVariableNames: 'dataStream mimeStream'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Streams'!
MimeConverter subclass: #Base64MimeConverter
instanceVariableNames: 'data'
classVariableNames: 'FromCharTable ToCharTable'
poolDictionaries: ''
category: 'Collections-Streams'!
!Base64MimeConverter commentStamp: '<historical>' prior: 0!
This class encodes and decodes data in Base64 format. This is MIME encoding. We translate a whole stream at once, taking a Stream as input and giving one as output. Returns a whole stream for the caller to use.
0 A 17 R 34 i 51 z
1 B 18 S 35 j 52 0
2 C 19 T 36 k 53 1
3 D 20 U 37 l 54 2
4 E 21 V 38 m 55 3
5 F 22 W 39 n 56 4
6 G 23 X 40 o 57 5
7 H 24 Y 41 p 58 6
8 I 25 Z 42 q 59 7
9 J 26 a 43 r 60 8
10 K 27 b 44 s 61 9
11 L 28 c 45 t 62 +
12 M 29 d 46 u 63 /
13 N 30 e 47 v
14 O 31 f 48 w (pad) =
15 P 32 g 49 x
16 Q 33 h 50 y
Outbound: bytes are broken into 6 bit chunks, and the 0-63 value is converted to a character. 3 data bytes go into 4 characters.
Inbound: Characters are translated in to 0-63 values and shifted into 8 bit bytes.
(See: N. Borenstein, Bellcore, N. Freed, Innosoft, Network Working Group, Request for Comments: RFC 1521, September 1993, MIME (Multipurpose Internet Mail Extensions) Part One: Mechanisms for Specifying and Describing the Format of Internet Message Bodies. Sec 6.2)
By Ted Kaehler, based on Tim Olson's Base64Filter.!
----- Method: Base64MimeConverter class>>decodeInteger: (in category 'as yet unclassified') -----
decodeInteger: mimeString
| bytes sum |
"Decode the MIME string into an integer of any length"
bytes _ (Base64MimeConverter mimeDecodeToBytes:
(ReadStream on: mimeString)) contents.
sum _ 0.
bytes reverseDo: [:by | sum _ sum * 256 + by].
^ sum!
----- Method: Base64MimeConverter class>>encodeInteger: (in category 'as yet unclassified') -----
encodeInteger: int
| strm |
"Encode an integer of any length and return the MIME string"
strm _ ReadWriteStream on: (ByteArray new: int digitLength).
1 to: int digitLength do: [:ii | strm nextPut: (int digitAt: ii)].
strm reset.
^ ((self mimeEncode: strm) contents) copyUpTo: $= "remove padding"!
----- Method: Base64MimeConverter class>>initialize (in category 'as yet unclassified') -----
initialize
FromCharTable _ Array new: 256. "nils"
ToCharTable _ Array new: 64.
($A asciiValue to: $Z asciiValue) doWithIndex: [:val :ind |
FromCharTable at: val+1 put: ind-1.
ToCharTable at: ind put: val asCharacter].
($a asciiValue to: $z asciiValue) doWithIndex: [:val :ind |
FromCharTable at: val+1 put: ind+25.
ToCharTable at: ind+26 put: val asCharacter].
($0 asciiValue to: $9 asciiValue) doWithIndex: [:val :ind |
FromCharTable at: val+1 put: ind+25+26.
ToCharTable at: ind+26+26 put: val asCharacter].
FromCharTable at: $+ asciiValue + 1 put: 62.
ToCharTable at: 63 put: $+.
FromCharTable at: $/ asciiValue + 1 put: 63.
ToCharTable at: 64 put: $/.
!
----- Method: Base64MimeConverter class>>mimeDecodeToBytes: (in category 'as yet unclassified') -----
mimeDecodeToBytes: aStream
"Return a RWBinaryOrTextStream of the original ByteArray. aStream has only 65 innocuous character values. aStream is not binary. (See class comment). 4 bytes in aStream goes to 3 bytes in output."
| me |
aStream position: 0.
me _ self new mimeStream: aStream.
me dataStream: (RWBinaryOrTextStream on: (ByteArray new: aStream size * 3 // 4)).
me mimeDecodeToByteArray.
me dataStream position: 0.
^ me dataStream!
----- Method: Base64MimeConverter class>>mimeDecodeToChars: (in category 'as yet unclassified') -----
mimeDecodeToChars: aStream
"Return a ReadWriteStream of the original String. aStream has only 65 innocuous character values. It is not binary. (See class comment). 4 bytes in aStream goes to 3 bytes in output."
| me |
aStream position: 0.
me _ self new mimeStream: aStream.
me dataStream: (ReadWriteStream on: (String new: aStream size * 3 // 4)).
me mimeDecode.
me dataStream position: 0.
^ me dataStream!
----- Method: Base64MimeConverter class>>mimeEncode: (in category 'as yet unclassified') -----
mimeEncode: aStream
"Return a ReadWriteStream of characters. The data of aStream is encoded as 65 innocuous characters. (See class comment). 3 bytes in aStream goes to 4 bytes in output."
| me |
aStream position: 0.
me _ self new dataStream: aStream.
me mimeStream: (ReadWriteStream on: (String new: aStream size + 20 * 4 // 3)).
me mimeEncode.
me mimeStream position: 0.
^ me mimeStream!
----- Method: Base64MimeConverter>>mimeDecode (in category 'conversion') -----
mimeDecode
"Convert a stream in base 64 with only a-z,A-Z,0-9,+,/ to a full byte stream of characters. Reutrn a whole stream for the user to read."
| nibA nibB nibC nibD |
[mimeStream atEnd] whileFalse: [
(nibA _ self nextValue) ifNil: [^ dataStream].
(nibB _ self nextValue) ifNil: [^ dataStream].
dataStream nextPut: ((nibA bitShift: 2) + (nibB bitShift: -4)) asCharacter.
nibB _ nibB bitAnd: 16rF.
(nibC _ self nextValue) ifNil: [^ dataStream].
dataStream nextPut: ((nibB bitShift: 4) + (nibC bitShift: -2)) asCharacter.
nibC _ nibC bitAnd: 16r3.
(nibD _ self nextValue) ifNil: [^ dataStream].
dataStream nextPut: ((nibC bitShift: 6) + nibD) asCharacter.
].
^ dataStream!
----- Method: Base64MimeConverter>>mimeDecodeToByteArray (in category 'conversion') -----
mimeDecodeToByteArray
"Convert a stream in base 64 with only a-z,A-Z,0-9,+,/ to a full ByteArray of 0-255 values. Reutrn a whole stream for the user to read."
| nibA nibB nibC nibD |
[mimeStream atEnd] whileFalse: [
(nibA _ self nextValue) ifNil: [^ dataStream].
(nibB _ self nextValue) ifNil: [^ dataStream].
dataStream nextPut: ((nibA bitShift: 2) + (nibB bitShift: -4)).
nibB _ nibB bitAnd: 16rF.
(nibC _ self nextValue) ifNil: [^ dataStream].
dataStream nextPut: ((nibB bitShift: 4) + (nibC bitShift: -2)).
nibC _ nibC bitAnd: 16r3.
(nibD _ self nextValue) ifNil: [^ dataStream].
dataStream nextPut: ((nibC bitShift: 6) + nibD).
].
^ dataStream!
----- Method: Base64MimeConverter>>mimeEncode (in category 'conversion') -----
mimeEncode
"Convert from data to 6 bit characters."
| phase1 phase2 raw nib lineLength |
phase1 _ phase2 _ false.
lineLength := 0.
[dataStream atEnd] whileFalse: [
lineLength >= 70 ifTrue: [ mimeStream cr. lineLength := 0. ].
data _ raw _ dataStream next asInteger.
nib _ (data bitAnd: 16rFC) bitShift: -2.
mimeStream nextPut: (ToCharTable at: nib+1).
(raw _ dataStream next) ifNil: [raw _ 0. phase1 _ true].
data _ ((data bitAnd: 3) bitShift: 8) + raw asInteger.
nib _ (data bitAnd: 16r3F0) bitShift: -4.
mimeStream nextPut: (ToCharTable at: nib+1).
(raw _ dataStream next) ifNil: [raw _ 0. phase2 _ true].
data _ ((data bitAnd: 16rF) bitShift: 8) + (raw asInteger).
nib _ (data bitAnd: 16rFC0) bitShift: -6.
mimeStream nextPut: (ToCharTable at: nib+1).
nib _ (data bitAnd: 16r3F).
mimeStream nextPut: (ToCharTable at: nib+1).
lineLength := lineLength + 4.].
phase1 ifTrue: [mimeStream skip: -2; nextPut: $=; nextPut: $=.
^ mimeStream].
phase2 ifTrue: [mimeStream skip: -1; nextPut: $=.
^ mimeStream].
!
----- Method: Base64MimeConverter>>nextValue (in category 'conversion') -----
nextValue
"The next six bits of data char from the mimeStream, or nil. Skip all other chars"
| raw num |
[raw _ mimeStream next.
raw ifNil: [^ nil]. "end of stream"
raw == $= ifTrue: [^ nil].
num _ FromCharTable at: raw asciiValue + 1.
num ifNotNil: [^ num].
"else ignore space, return, tab, ..."
true] whileTrue.!
----- Method: MimeConverter class>>forEncoding: (in category 'convenience') -----
forEncoding: encodingString
"Answer a converter class for the given encoding or nil if unknown"
encodingString ifNil: [^nil].
^ encodingString asLowercase caseOf:
{ ['base64'] -> [Base64MimeConverter].
['quoted-printable'] -> [QuotedPrintableMimeConverter]}
otherwise: [].
!
----- Method: MimeConverter class>>mimeDecode:as: (in category 'convenience') -----
mimeDecode: aStringOrStream as: contentsClass
^ contentsClass streamContents: [:out |
self mimeDecode: aStringOrStream to: out]!
----- Method: MimeConverter class>>mimeDecode:to: (in category 'convenience') -----
mimeDecode: aStringOrStream to: outStream
self new
mimeStream: (aStringOrStream isStream
ifTrue: [aStringOrStream]
ifFalse: [ReadStream on: aStringOrStream]);
dataStream: outStream;
mimeDecode!
----- Method: MimeConverter class>>mimeEncode: (in category 'convenience') -----
mimeEncode: aCollectionOrStream
^ String streamContents: [:out |
self mimeEncode: aCollectionOrStream to: out]!
----- Method: MimeConverter class>>mimeEncode:to: (in category 'convenience') -----
mimeEncode: aCollectionOrStream to: outStream
self new
dataStream: (aCollectionOrStream isStream
ifTrue: [aCollectionOrStream]
ifFalse: [ReadStream on: aCollectionOrStream]);
mimeStream: outStream;
mimeEncode!
----- Method: MimeConverter>>dataStream (in category 'accessing') -----
dataStream
^dataStream!
----- Method: MimeConverter>>dataStream: (in category 'accessing') -----
dataStream: anObject
dataStream _ anObject!
----- Method: MimeConverter>>mimeDecode (in category 'conversion') -----
mimeDecode
"Do conversion reading from mimeStream writing to dataStream"
self subclassResponsibility!
----- Method: MimeConverter>>mimeEncode (in category 'conversion') -----
mimeEncode
"Do conversion reading from dataStream writing to mimeStream"
self subclassResponsibility!
----- Method: MimeConverter>>mimeStream (in category 'accessing') -----
mimeStream
^mimeStream!
----- Method: MimeConverter>>mimeStream: (in category 'accessing') -----
mimeStream: anObject
mimeStream _ anObject!
MimeConverter subclass: #QuotedPrintableMimeConverter
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Streams'!
!QuotedPrintableMimeConverter commentStamp: '<historical>' prior: 0!
I do quoted printable MIME decoding as specified in RFC 2045 "MIME Part One: Format of Internet Message Bodies".
Short version of RFC2045, Sect. 6.7:
(1) Any octet, except a CR or LF that is part of a CRLF line break of the canonical (standard) form of the data being encoded, may be represented by an "=" followed by a two digit hexadecimal representation of the octet's value. [...]
(2) Octets with decimal values of 33 through 60 inclusive, and 62 through 126, inclusive, MAY be represented as the US-ASCII characters which correspond to those octets [...].
(3) Octets with values of 9 and 32 MAY be represented as US-ASCII TAB (HT) and SPACE characters,
respectively, but MUST NOT be so represented at the end of an encoded line. [...]
(4) A line break in a text body, represented as a CRLF sequence in the text canonical form, must be represented by a (RFC 822) line break, which is also a CRLF sequence, in the Quoted-Printable encoding. [...]
(5) The Quoted-Printable encoding REQUIRES that encoded lines be no more than 76 characters long. If longer lines are to be encoded with the Quoted-Printable encoding, "soft" line breaks
must be used. An equal sign as the last character on a encoded line indicates such a non-significant ("soft") line break in the encoded text.
--bf 11/27/1998 16:50!
----- Method: QuotedPrintableMimeConverter>>mimeDecode (in category 'conversion') -----
mimeDecode
"Do conversion reading from mimeStream writing to dataStream"
| line s c1 v1 c2 v2 |
[(line _ mimeStream nextLine) isNil] whileFalse: [
line _ line withoutTrailingBlanks.
line size = 0
ifTrue: [dataStream cr]
ifFalse: [
s _ ReadStream on: line.
[dataStream nextPutAll: (s upTo: $=).
s atEnd] whileFalse: [
c1 _ s next. v1 _ c1 digitValue.
((v1 between: 0 and: 15) and: [s atEnd not])
ifFalse: [dataStream nextPut: $=; nextPut: c1]
ifTrue: [c2 _ s next. v2 _ c2 digitValue.
(v2 between: 0 and: 15)
ifFalse: [dataStream nextPut: $=; nextPut: c1; nextPut: c2]
ifTrue: [dataStream nextPut: (Character value: v1 * 16 + v2)]]].
line last = $= ifFalse: [dataStream cr]]].
^ dataStream!
QuotedPrintableMimeConverter subclass: #RFC2047MimeConverter
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Streams'!
!RFC2047MimeConverter commentStamp: '<historical>' prior: 0!
I do quoted printable MIME decoding as specified in RFC 2047 ""MIME Part Three: Message Header Extensions for Non-ASCII Text". See String>>decodeMimeHeader!
----- Method: RFC2047MimeConverter>>encodeChar:to: (in category 'private-encoding') -----
encodeChar: aChar to: aStream
aChar = Character space
ifTrue: [^ aStream nextPut: $_].
((aChar asciiValue between: 32 and: 127) and: [('?=_' includes: aChar) not])
ifTrue: [^ aStream nextPut: aChar].
aStream nextPut: $=;
nextPut: (Character digitValue: aChar asciiValue // 16);
nextPut: (Character digitValue: aChar asciiValue \\ 16)
!
----- Method: RFC2047MimeConverter>>encodeWord: (in category 'private-encoding') -----
encodeWord: aString
(aString allSatisfy: [:c | c asciiValue < 128])
ifTrue: [^ aString].
^ String streamContents: [:stream |
stream nextPutAll: '=?iso-8859-1?Q?'.
aString do: [:c | self encodeChar: c to: stream].
stream nextPutAll: '?=']!
----- Method: RFC2047MimeConverter>>isStructuredField: (in category 'private-encoding') -----
isStructuredField: aString
| fName |
fName _ aString copyUpTo: $:.
('Resent' sameAs: (fName copyUpTo: $-))
ifTrue: [fName _ fName copyFrom: 8 to: fName size].
^#('Sender' 'From' 'Reply-To' 'To' 'cc' 'bcc') anySatisfy: [:each | fName sameAs: each]!
----- Method: RFC2047MimeConverter>>mimeDecode (in category 'conversion') -----
mimeDecode
"Do conversion reading from mimeStream writing to dataStream. See String>>decodeMimeHeader"
| c |
[mimeStream atEnd] whileFalse: [
c _ mimeStream next.
c = $=
ifTrue: [c _ Character value: mimeStream next digitValue * 16
+ mimeStream next digitValue]
ifFalse: [c = $_ ifTrue: [c _ $ ]].
dataStream nextPut: c].
^ dataStream!
----- Method: RFC2047MimeConverter>>mimeEncode (in category 'conversion') -----
mimeEncode
"Do conversion reading from dataStream writing to mimeStream. Break long lines and escape non-7bit chars."
| word pos wasGood isGood max |
true ifTrue: [mimeStream nextPutAll: dataStream upToEnd].
pos _ 0.
max _ 72.
wasGood _ true.
[dataStream atEnd] whileFalse: [
word _ self readWord.
isGood _ word allSatisfy: [:c | c asciiValue < 128].
wasGood & isGood ifTrue: [
pos + word size < max
ifTrue: [dataStream nextPutAll: word.
pos _ pos + word size]
ifFalse: []
]
].
^ mimeStream!
----- Method: RFC2047MimeConverter>>readWord (in category 'private-encoding') -----
readWord
| strm |
strm _ WriteStream on: (String new: 20)
dataStream skipSeparators.
[dataStream atEnd] whileFalse:
[ | c |
c _ dataStream next.
strm nextPut: c.
c isSeparator ifTrue: [^ strm contents]].
^ strm contents!
Object subclass: #SharedQueue
instanceVariableNames: 'contentsArray readPosition writePosition accessProtect readSynch'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Sequenceable'!
!SharedQueue commentStamp: '<historical>' prior: 0!
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.!
----- Method: SharedQueue class>>new (in category 'instance creation') -----
new
"Answer a new instance of SharedQueue that has 10 elements."
^self new: 10!
----- Method: SharedQueue class>>new: (in category 'instance creation') -----
new: anInteger
^super new init: anInteger!
----- Method: SharedQueue>>flush (in category 'accessing') -----
flush
"Throw out all pending contents"
accessProtect critical: [
"nil out flushed slots --bf 02/11/2006"
contentsArray from: readPosition to: writePosition-1 put: nil.
readPosition _ 1.
writePosition _ 1.
"Reset the read synchronization semaphore"
readSynch initSignals].!
----- Method: SharedQueue>>flushAllSuchThat: (in category 'accessing') -----
flushAllSuchThat: aBlock
"Remove from the queue all objects that satisfy aBlock, and answer them"
| removed value newReadPos |
removed := OrderedCollection new: self size.
accessProtect critical: [
newReadPos _ writePosition.
writePosition-1 to: readPosition by: -1 do:
[:i | value _ contentsArray at: i.
contentsArray at: i put: nil.
(aBlock value: value) ifTrue: [
removed addFirst: value.
"We take an element out of the queue, and therefore, we need to decrement
the readSynch signals"
readSynch wait.
] ifFalse: [
newReadPos _ newReadPos - 1.
contentsArray at: newReadPos put: value]].
readPosition _ newReadPos].
^removed
!
----- Method: SharedQueue>>init: (in category 'private') -----
init: size
contentsArray _ Array new: size.
readPosition _ 1.
writePosition _ 1.
accessProtect _ Semaphore forMutualExclusion.
readSynch _ Semaphore new!
----- Method: SharedQueue>>isEmpty (in category 'testing') -----
isEmpty
"Answer whether any objects have been sent through the receiver and
not yet received by anyone."
^readPosition = writePosition!
----- Method: SharedQueue>>makeRoomAtEnd (in category 'private') -----
makeRoomAtEnd
| contentsSize |
readPosition = 1
ifTrue: [contentsArray _ contentsArray , (Array new: 10)]
ifFalse:
[contentsSize _ writePosition - readPosition.
"BLT direction ok for this. Lots faster!!!!!!!!!!!! SqR!!!! 4/10/2000 10:47"
contentsArray
replaceFrom: 1
to: contentsSize
with: contentsArray
startingAt: readPosition.
"nil out remainder --bf 10/25/2005"
contentsArray
from: contentsSize+1
to: contentsArray size
put: nil.
readPosition _ 1.
writePosition _ contentsSize + 1]!
----- Method: SharedQueue>>next (in category '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!
----- Method: SharedQueue>>nextOrNil (in category 'accessing') -----
nextOrNil
"Answer the object that was sent through the receiver first and has not
yet been received by anyone. If no object has been sent, answer <nil>."
| value |
accessProtect critical: [
readPosition >= writePosition ifTrue: [
value := nil
] ifFalse: [
value := contentsArray at: readPosition.
contentsArray at: readPosition put: nil.
readPosition := readPosition + 1.
readSynch wait.
].
].
^value!
----- Method: SharedQueue>>nextOrNilSuchThat: (in category 'accessing') -----
nextOrNilSuchThat: aBlock
"Answer the next object that satisfies aBlock, or nil otherwise.
Leave other enqueued objects in place."
| i each |
accessProtect critical: [
i := readPosition.
[i < writePosition] whileTrue: [
each := contentsArray at: i.
(aBlock value: each) ifTrue: [
[i > readPosition] whileTrue: [
contentsArray at: i put: (contentsArray at: i-1).
i := i - 1].
contentsArray at: readPosition put: nil.
readPosition := readPosition + 1.
readSynch wait.
^each].
i := i + 1.
].
].
^nil
"===
| q c v |
q := SharedQueue new.
1 to: 10 do: [ :i | q nextPut: i].
c := OrderedCollection new.
[
v := q nextOrNilSuchThat: [ :e | e odd].
v notNil
] whileTrue: [
c add: {v. q size}
].
{c. q}
==="!
----- Method: SharedQueue>>nextPut: (in category 'accessing') -----
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!
----- Method: SharedQueue>>peek (in category 'accessing') -----
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, return nil"
| value |
accessProtect
critical: [readPosition >= writePosition
ifTrue: [readPosition _ 1.
writePosition _ 1.
value _ nil]
ifFalse: [value _ contentsArray at: readPosition]].
^value!
----- Method: SharedQueue>>size (in category 'accessing') -----
size
"Answer the number of objects that have been sent through the
receiver and not yet received by anyone."
^writePosition - readPosition!
Object subclass: #SkipListNode
instanceVariableNames: 'pointers object'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-SkipLists'!
----- Method: SkipListNode class>>new: (in category 'instance creation') -----
new: maxLevel
^ super new initialize: maxLevel!
----- Method: SkipListNode class>>on:level: (in category 'instance creation') -----
on: element level: maxLevel
^ (self new: maxLevel)
object: element!
----- Method: SkipListNode class>>tailOfLevel: (in category 'instance creation') -----
tailOfLevel: n
^ self on: nil level: n!
----- Method: SkipListNode>>atForward:put: (in category 'accessing') -----
atForward: i put: node
^ pointers at: i put: node!
----- Method: SkipListNode>>forward: (in category 'accessing') -----
forward: i
^ pointers at: i!
----- Method: SkipListNode>>initialize: (in category 'initialization') -----
initialize: maxLevel
pointers _ Array new: maxLevel!
----- Method: SkipListNode>>level (in category 'accessing') -----
level
^ pointers size!
----- Method: SkipListNode>>next (in category 'accessing') -----
next
^ pointers first!
----- Method: SkipListNode>>object (in category 'accessing') -----
object
^ object!
----- Method: SkipListNode>>object: (in category 'private') -----
object: anObject
object _ anObject!
----- Method: SkipListNode>>printOn: (in category 'printing') -----
printOn: aStream
| first |
aStream
nextPut: $[;
nextPutAll: object printString;
nextPutAll: ']-->('.
first _ true.
pointers do: [:node |
first ifTrue: [first _ false] ifFalse: [aStream space].
aStream nextPutAll: (node ifNil: ['*'] ifNotNil: [node object printString])].
aStream nextPut: $)
!
Object subclass: #Stream
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Streams'!
!Stream commentStamp: '<historical>' prior: 0!
I am an abstract class that represents an accessor for a sequence of objects. This sequence is referred to as my "contents".!
Stream subclass: #AttributedTextStream
instanceVariableNames: 'characters attributeRuns attributeValues currentAttributes currentRun'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Streams'!
!AttributedTextStream commentStamp: '<historical>' prior: 0!
a stream on Text's which keeps track of the last attribute put; new characters are added with those attributes.
instance vars:
characters - a WriteStream of the characters in the stream
attributeRuns - a RunArray with the attributes for the stream
currentAttributes - the attributes to be used for new text
attributesChanged - whether the attributes have changed since the last addition!
----- Method: AttributedTextStream class>>new (in category 'instance creation') -----
new
"For this class we override Stream class>>new since this
class actually is created using #new, even though it is a Stream."
^self basicNew initialize!
----- Method: AttributedTextStream>>contents (in category 'retrieving the text') -----
contents
| ans |
currentRun > 0 ifTrue:[
attributeValues nextPut: currentAttributes.
attributeRuns nextPut: currentRun.
currentRun _ 0].
ans _ Text new: characters size.
"this is declared private, but it's exactly what I need, and it's declared as exactly what I want it to do...."
ans setString: characters contents setRuns:
(RunArray runs: attributeRuns contents values: attributeValues contents).
^ans!
----- Method: AttributedTextStream>>currentAttributes (in category 'access') -----
currentAttributes
"return the current attributes"
^currentAttributes!
----- Method: AttributedTextStream>>currentAttributes: (in category 'access') -----
currentAttributes: newAttributes
"set the current attributes"
(currentRun > 0 and:[currentAttributes ~= newAttributes]) ifTrue:[
attributeRuns nextPut: currentRun.
attributeValues nextPut: currentAttributes.
currentRun _ 0.
].
currentAttributes _ newAttributes.
!
----- Method: AttributedTextStream>>initialize (in category 'private-initialization') -----
initialize
characters _ WriteStream on: String new.
currentAttributes _ OrderedCollection new.
currentRun _ 0.
attributeValues _ WriteStream on: (Array new: 50).
attributeRuns _ WriteStream on: (Array new: 50). !
----- Method: AttributedTextStream>>nextPut: (in category 'stream protocol') -----
nextPut: aChar
currentRun _ currentRun + 1.
characters nextPut: aChar!
----- Method: AttributedTextStream>>nextPutAll: (in category 'stream protocol') -----
nextPutAll: aString
"add an entire string with the same attributes"
currentRun _ currentRun + aString size.
characters nextPutAll: aString.!
----- Method: AttributedTextStream>>size (in category 'access') -----
size
"number of characters in the stream so far"
^characters size!
Stream subclass: #PositionableStream
instanceVariableNames: 'collection position readLimit'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Streams'!
!PositionableStream commentStamp: '<historical>' prior: 0!
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.!
----- Method: PositionableStream class>>on: (in category 'instance creation') -----
on: aCollection
"Answer an instance of me, streaming over the elements of aCollection."
^self basicNew on: aCollection!
----- Method: PositionableStream class>>on:from:to: (in category 'instance creation') -----
on: aCollection from: firstIndex to: lastIndex
"Answer an instance of me, streaming over the elements of aCollection
starting with the element at firstIndex and ending with the one at
lastIndex."
^self basicNew on: (aCollection copyFrom: firstIndex to: lastIndex)!
----- Method: PositionableStream>>asBinaryOrTextStream (in category 'converting') -----
asBinaryOrTextStream
"Convert to a stream that can switch between bytes and characters"
^ (RWBinaryOrTextStream with: self contentsOfEntireFile) reset!
----- Method: PositionableStream>>asZLibReadStream (in category 'converting') -----
asZLibReadStream
^ZLibReadStream on: collection from: position+1 to: readLimit!
----- Method: PositionableStream>>atEnd (in category 'testing') -----
atEnd
"Primitive. Answer whether the receiver can access any more objects.
Optional. See Object documentation whatIsAPrimitive."
<primitive: 67>
^position >= readLimit!
----- Method: PositionableStream>>back (in category 'accessing') -----
back
"Go back one element and return it. Use indirect messages in case I am a StandardFileStream"
self position = 0 ifTrue: [self errorCantGoBack].
self position = 1 ifTrue: [self position: 0. ^ nil].
self skip: -2.
^ self next
!
----- Method: PositionableStream>>backChunk (in category 'fileIn/Out') -----
backChunk
"Answer the contents of the receiver back to the previous terminator character. Doubled terminators indicate an embedded terminator character."
| terminator out ch |
terminator _ $!!.
out _ WriteStream on: (String new: 1000).
[(ch _ self back) == nil] whileFalse: [
(ch == terminator) ifTrue: [
self peekBack == terminator ifTrue: [
self back. "skip doubled terminator"
] ifFalse: [
^ out contents reversed "we're done!!"
].
].
out nextPut: ch.
].
^ out contents reversed!
----- Method: PositionableStream>>backUpTo: (in category 'positioning') -----
backUpTo: subCollection
"Back up the position to he subCollection. Position must be somewhere within the stream initially. Leave it just after it. Return true if succeeded. No wildcards, and case does matter."
"Example:
| strm | strm _ ReadStream on: 'zabc abdc'.
strm setToEnd; backUpTo: 'abc'; position
"
| pattern startMatch |
pattern _ ReadStream on: subCollection reversed.
startMatch _ nil.
[pattern atEnd] whileFalse:
[self position = 0 ifTrue: [^ false].
self skip: -1.
(self next) = (pattern next)
ifTrue: [pattern position = 1 ifTrue: [startMatch _ self position]]
ifFalse: [pattern position: 0.
startMatch ifNotNil: [
self position: startMatch-1.
startMatch _ nil]].
self skip: -1].
self position: startMatch.
^ true
!
----- Method: PositionableStream>>basicNextChunk (in category 'fileIn/Out') -----
basicNextChunk
"Answer the contents of the receiver, up to the next terminator character. Doubled terminators indicate an embedded terminator character."
| terminator out ch |
terminator _ $!!.
out _ WriteStream on: (String new: 1000).
self skipSeparators.
[(ch _ self next) == nil] whileFalse: [
(ch == terminator) ifTrue: [
self peek == terminator ifTrue: [
self next. "skip doubled terminator"
] ifFalse: [
^ out contents "terminator is not doubled; we're done!!"
].
].
out nextPut: ch.
].
^ out contents!
----- Method: PositionableStream>>boolean (in category 'data get/put') -----
boolean
"Answer the next boolean value from this (binary) stream."
^ self next ~= 0
!
----- Method: PositionableStream>>boolean: (in category 'data get/put') -----
boolean: aBoolean
"Store the given boolean value on this (binary) stream."
self nextPut: (aBoolean ifTrue: [1] ifFalse: [0]).
!
----- Method: PositionableStream>>checkForPreamble: (in category 'fileIn/Out') -----
checkForPreamble: chunk
((chunk beginsWith: '"Change Set:') and: [ChangeSet current preambleString == nil])
ifTrue: [ChangeSet current preambleString: chunk].
((chunk beginsWith: '"Postscript:') and: [ChangeSet current postscriptString == nil])
ifTrue: [ChangeSet current postscriptString: chunk].
!
----- Method: PositionableStream>>command: (in category 'fileIn/Out') -----
command: aString
"Overridden by HtmlFileStream to append commands directly without translation. 4/5/96 tk"
"We ignore any HTML commands. Do nothing"!
----- Method: PositionableStream>>contents (in category 'accessing') -----
contents
"Answer with a copy of my collection from 1 to readLimit."
^collection copyFrom: 1 to: readLimit!
----- Method: PositionableStream>>contentsOfEntireFile (in category 'accessing') -----
contentsOfEntireFile
"For non-file streams"
^ self contents!
----- Method: PositionableStream>>copyMethodChunkFrom: (in category 'fileIn/Out') -----
copyMethodChunkFrom: aStream
"Copy the next chunk from aStream (must be different from the receiver)."
| chunk |
chunk _ aStream nextChunkText.
chunk runs values size = 1 "Optimize for unembellished text"
ifTrue: [self nextChunkPut: chunk asString]
ifFalse: [self nextChunkPutWithStyle: chunk]!
----- Method: PositionableStream>>copyMethodChunkFrom:at: (in category 'fileIn/Out') -----
copyMethodChunkFrom: aStream at: pos
"Copy the next chunk from aStream (must be different from the receiver)."
| chunk |
aStream position: pos.
chunk _ aStream nextChunkText.
chunk runs values size = 1 "Optimize for unembellished text"
ifTrue: [self nextChunkPut: chunk asString]
ifFalse: [self nextChunkPutWithStyle: chunk]!
----- Method: PositionableStream>>copyPreamble:from:at: (in category 'filein/out') -----
copyPreamble: preamble from: aStream at: pos
"Look for a changeStamp for this method by peeking backward.
Write a method preamble, with that stamp if found."
| terminator methodPos p last50 stamp i |
terminator _ $!!.
"Look back to find stamp in old preamble, such as...
Polygon methodsFor: 'private' stamp: 'di 6/25/97 21:42' prior: 34957598!! "
aStream position: pos.
methodPos _ aStream position.
(aStream isMemberOf: MultiByteFileStream) ifTrue: [
aStream position: (p _ 0 max: methodPos-100).
last50 _ aStream basicNext: methodPos - p.
] ifFalse: [
aStream position: (p _ 0 max: methodPos-50).
last50 _ aStream next: methodPos - p.
].
stamp _ String new.
(i _ last50 findLastOccuranceOfString: 'stamp:' startingAt: 1) > 0 ifTrue:
[stamp _ (last50 copyFrom: i+8 to: last50 size) copyUpTo: $'].
"Write the new preamble, with old stamp if any."
self cr; nextPut: terminator.
self nextChunkPut: (String streamContents:
[:strm |
strm nextPutAll: preamble.
stamp size > 0 ifTrue:
[strm nextPutAll: ' stamp: '; print: stamp]]).
self cr!
----- Method: PositionableStream>>decodeString:andRuns: (in category 'fileIn/Out') -----
decodeString: string andRuns: runsRaw
| strm runLength runValues newString index |
strm _ ReadStream on: runsRaw from: 1 to: runsRaw size.
(strm peekFor: $( ) ifFalse: [^ nil].
runLength _ OrderedCollection new.
[strm skipSeparators.
strm peekFor: $)] whileFalse:
[runLength add: (Number readFrom: strm)].
runValues _ OrderedCollection new.
[strm atEnd not] whileTrue:
[runValues add: (Number readFrom: strm).
strm next.].
newString _ WideString new: string size.
index _ 1.
runLength with: runValues do: [:length :leadingChar |
index to: index + length - 1 do: [:pos |
newString at: pos put: (Character leadingChar: leadingChar code: (string at: pos) charCode).
].
index _ index + length.
].
^ newString.
!
----- Method: PositionableStream>>decodeStyle:version: (in category 'fileIn/Out') -----
decodeStyle: runsObjData version: styleVersion
"Decode the runs array from the ReferenceStream it is stored in."
"Verify that the class mentioned have the same inst vars as we have now"
| structureInfo |
styleVersion = RemoteString currentTextAttVersion ifTrue: [
"Matches our classes, no need for checking"
^ (ReferenceStream on: runsObjData) next].
structureInfo _ RemoteString structureAt: styleVersion. "or nil"
"See SmartRefStream instVarInfo: for dfn"
^ SmartRefStream read: runsObjData withClasses: structureInfo!
----- Method: PositionableStream>>fileIn (in category 'fileIn/Out') -----
fileIn
"This is special for reading expressions from text that has been formatted
with exclamation delimitors. The expressions are read and passed to the
Compiler. Answer the result of compilation."
| msg |
msg := self name = 'a stream' translated
ifTrue:
['']
ifFalse:
[self name].
^ self fileInAnnouncing: 'Reading ' translated, msg!
----- Method: PositionableStream>>fileInAnnouncing: (in category 'fileIn/Out') -----
fileInAnnouncing: announcement
"This is special for reading expressions from text that has been formatted
with exclamation delimitors. The expressions are read and passed to the
Compiler. Answer the result of compilation. Put up a progress report with
the given announcement as the title."
| val chunk classes reader |
classes := Set new.
classes add: UndefinedObject; add: ObjectScanner.
announcement
displayProgressAt: Sensor cursorPoint
from: 0
to: self size
during:
[:bar |
[self atEnd] whileFalse:
[bar value: self position.
self skipSeparators.
[val := (self peekFor: $!!)
ifTrue: [
reader := Compiler evaluate: self nextChunk logged: false.
(reader isMemberOf: ClassCategoryReader) ifTrue: [classes add: reader theClass].
reader scanFrom: self]
ifFalse:
[chunk := self nextChunk.
self checkForPreamble: chunk.
Compiler evaluate: chunk logged: true]]
on: InMidstOfFileinNotification
do: [:ex | ex resume: true].
self skipStyleChunk].
self close].
"Note: The main purpose of this banner is to flush the changes file."
SmalltalkImage current logChange: '----End fileIn of ' , self name , '----'.
classes do: [:c | c forgetDoIts].
^val!
----- Method: PositionableStream>>fileInFor:announcing: (in category 'fileIn/Out') -----
fileInFor: client announcing: announcement
"This is special for reading expressions from text that has been formatted
with exclamation delimitors. The expressions are read and passed to the
Compiler. Answer the result of compilation. Put up a progress report with
the given announcement as the title.
Does NOT handle preambles or postscripts specially."
| val chunk |
announcement displayProgressAt: Sensor cursorPoint
from: 0 to: self size
during:
[:bar |
[self atEnd]
whileFalse:
[bar value: self position.
self skipSeparators.
[ val _ (self peekFor: $!!) ifTrue: [
(Compiler evaluate: self nextChunk for: client logged: false) scanFrom: self
] ifFalse: [
chunk _ self nextChunk.
self checkForPreamble: chunk.
Compiler evaluate: chunk for: client logged: true ].
] on: InMidstOfFileinNotification
do: [ :ex | ex resume: true].
self atEnd ifFalse: [ self skipStyleChunk ]].
self close].
"Note: The main purpose of this banner is to flush the changes file."
SmalltalkImage current logChange: '----End fileIn of ' , self name , '----'.
Smalltalk forgetDoIts.
^ val!
----- Method: PositionableStream>>fileInSilentlyAnnouncing: (in category 'fileIn/Out') -----
fileInSilentlyAnnouncing: announcement
"This is special for reading expressions from text that has been formatted
with exclamation delimitors. The expressions are read and passed to the
Compiler. Answer the result of compilation. Put up a progress report with
the given announcement as the title."
| val chunk |
[self atEnd] whileFalse:
[self skipSeparators.
[val := (self peekFor: $!!)
ifTrue: [(Compiler evaluate: self nextChunk logged: false) scanFrom: self]
ifFalse:
[chunk := self nextChunk.
self checkForPreamble: chunk.
Compiler evaluate: chunk logged: true]]
on: InMidstOfFileinNotification
do: [:ex | ex resume: true].
self skipStyleChunk].
self close.
"Note: The main purpose of this banner is to flush the changes file."
SmalltalkImage current logChange: '----End fileIn of ' , self name , '----'.
self flag: #ThisMethodShouldNotBeThere. "sd"
SystemNavigation new allBehaviorsDo:
[:cl |
cl
removeSelectorSimply: #DoIt;
removeSelectorSimply: #DoItIn:].
^val!
----- Method: PositionableStream>>header (in category 'fileIn/Out') -----
header
"If the stream requires a standard header, override this message. See HtmlFileStream"!
----- Method: PositionableStream>>int16 (in category 'data get/put') -----
int16
"Answer the next signed, 16-bit integer from this (binary) stream."
| n |
n _ self next.
n _ (n bitShift: 8) + (self next).
n >= 16r8000 ifTrue: [n _ n - 16r10000].
^ n
!
----- Method: PositionableStream>>int16: (in category 'data get/put') -----
int16: anInteger
"Store the given signed, 16-bit integer on this (binary) stream."
| n |
(anInteger < -16r8000) | (anInteger >= 16r8000)
ifTrue: [self error: 'outside 16-bit integer range'].
anInteger < 0
ifTrue: [n _ 16r10000 + anInteger]
ifFalse: [n _ anInteger].
self nextPut: (n digitAt: 2).
self nextPut: (n digitAt: 1).
!
----- Method: PositionableStream>>int32 (in category 'data get/put') -----
int32
"Answer the next signed, 32-bit integer from this (binary) stream."
"Details: As a fast check for negative number, check the high bit of the first digit"
| n firstDigit |
n _ firstDigit _ self next.
n _ (n bitShift: 8) + self next.
n _ (n bitShift: 8) + self next.
n _ (n bitShift: 8) + self next.
firstDigit >= 128 ifTrue: [n _ -16r100000000 + n]. "decode negative 32-bit integer"
^ n
!
----- Method: PositionableStream>>int32: (in category 'data get/put') -----
int32: anInteger
"Store the given signed, 32-bit integer on this (binary) stream."
| n |
(anInteger < -16r80000000) | (anInteger >= 16r80000000)
ifTrue: [self error: 'outside 32-bit integer range'].
anInteger < 0
ifTrue: [n _ 16r100000000 + anInteger]
ifFalse: [n _ anInteger].
self nextPut: (n digitAt: 4).
self nextPut: (n digitAt: 3).
self nextPut: (n digitAt: 2).
self nextPut: (n digitAt: 1).
!
----- Method: PositionableStream>>isBinary (in category 'testing') -----
isBinary
"Return true if the receiver is a binary byte stream"
^collection class == ByteArray!
----- Method: PositionableStream>>isEmpty (in category 'testing') -----
isEmpty
"Answer whether the receiver's contents has no elements."
^position = 0!
----- Method: PositionableStream>>last (in category 'accessing') -----
last
"Return the final element in the receiver"
^ collection at: position!
----- Method: PositionableStream>>match: (in category 'positioning') -----
match: subCollection
"Set the access position of the receiver to be past the next occurrence of the subCollection. Answer whether subCollection is found. No wildcards, and case does matter."
| pattern startMatch |
pattern _ ReadStream on: subCollection.
startMatch _ nil.
[pattern atEnd] whileFalse:
[self atEnd ifTrue: [^ false].
(self next) = (pattern next)
ifTrue: [pattern position = 1 ifTrue: [startMatch _ self position]]
ifFalse: [pattern position: 0.
startMatch ifNotNil: [
self position: startMatch.
startMatch _ nil]]].
^ true
!
----- Method: PositionableStream>>next: (in category '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].
^newArray!
----- Method: PositionableStream>>next:into: (in category 'accessing') -----
next: n into: aCollection
"Read n objects into the given collection.
Return aCollection or a partial copy if less than
n elements have been read."
^self next: n into: aCollection startingAt: 1!
----- Method: PositionableStream>>next:into:startingAt: (in category 'accessing') -----
next: n into: aCollection startingAt: startIndex
"Read n objects into the given collection.
Return aCollection or a partial copy if less than
n elements have been read."
| obj |
0 to: n-1 do:[:i|
(obj _ self next) == nil ifTrue:[^aCollection copyFrom: 1 to: startIndex+i-1].
aCollection at: startIndex+i put: obj].
^aCollection!
----- Method: PositionableStream>>next:putAll: (in category 'accessing') -----
next: anInteger putAll: aCollection
"Store the next anInteger elements from the given collection."
^self next: anInteger putAll: aCollection startingAt: 1!
----- Method: PositionableStream>>next:putAll:startingAt: (in category 'accessing') -----
next: anInteger putAll: aCollection startingAt: startIndex
"Store the next anInteger elements from the given collection."
(startIndex = 1 and:[anInteger = aCollection size])
ifTrue:[^self nextPutAll: aCollection].
^self nextPutAll: (aCollection copyFrom: startIndex to: startIndex+anInteger-1)!
----- Method: PositionableStream>>nextChunk (in category 'fileIn/Out') -----
nextChunk
"Answer the contents of the receiver, up to the next terminator character. Doubled terminators indicate an embedded terminator character."
| terminator out ch |
terminator _ $!!.
out _ WriteStream on: (String new: 1000).
self skipSeparators.
[(ch _ self next) == nil] whileFalse: [
(ch == terminator) ifTrue: [
self peek == terminator ifTrue: [
self next. "skip doubled terminator"
] ifFalse: [
^ self parseLangTagFor: out contents "terminator is not doubled; we're done!!"
].
].
out nextPut: ch.
].
^ self parseLangTagFor: out contents.
!
----- Method: PositionableStream>>nextChunkText (in category 'fileIn/Out') -----
nextChunkText
"Deliver the next chunk as a Text. Decode the following ]style[ chunk if present. Position at start of next real chunk."
| string runsRaw strm runs peek pos |
"Read the plain text"
string _ self nextChunk.
"Test for ]style[ tag"
pos _ self position.
peek _ self skipSeparatorsAndPeekNext.
peek = $] ifFalse: [self position: pos. ^ string asText]. "no tag"
(self upTo: $[) = ']style' ifFalse: [self position: pos. ^ string asText]. "different tag"
"Read and decode the style chunk"
runsRaw _ self basicNextChunk. "style encoding"
strm _ ReadStream on: runsRaw from: 1 to: runsRaw size.
runs _ RunArray scanFrom: strm.
^ Text basicNew setString: string setRunsChecking: runs.
!
----- Method: PositionableStream>>nextDelimited: (in category 'accessing') -----
nextDelimited: terminator
"Answer the contents of the receiver, up to the next terminator character. Doubled terminators indicate an embedded terminator character. For example: 'this '' was a quote'. Start postioned before the initial terminator."
| out ch |
out _ WriteStream on: (String new: 1000).
self atEnd ifTrue: [^ ''].
self next == terminator ifFalse: [self skip: -1]. "absorb initial terminator"
[(ch _ self next) == nil] whileFalse: [
(ch == terminator) ifTrue: [
self peek == terminator ifTrue: [
self next. "skip doubled terminator"
] ifFalse: [
^ out contents "terminator is not doubled; we're done!!"
].
].
out nextPut: ch.
].
^ out contents!
----- Method: PositionableStream>>nextInt32 (in category 'nonhomogeneous accessing') -----
nextInt32
"Read a 32-bit signed integer from the next 4 bytes"
| s |
s _ 0.
1 to: 4 do: [:i | s _ (s bitShift: 8) + self next].
(s bitAnd: 16r80000000) = 0
ifTrue: [^ s]
ifFalse: [^ -1 - s bitInvert32]!
----- Method: PositionableStream>>nextInt32Put: (in category 'nonhomogeneous accessing') -----
nextInt32Put: int32
"Write a signed integer to the next 4 bytes"
| pos |
pos _ int32 < 0
ifTrue: [(0-int32) bitInvert32 + 1]
ifFalse: [int32].
1 to: 4 do: [:i | self nextPut: (pos digitAt: 5-i)].
^ int32!
----- Method: PositionableStream>>nextInto: (in category 'accessing') -----
nextInto: aCollection
"Read the next elements of the receiver into aCollection.
Return aCollection or a partial copy if less than aCollection
size elements have been read."
^self next: aCollection size into: aCollection startingAt: 1.!
----- Method: PositionableStream>>nextInto:startingAt: (in category 'accessing') -----
nextInto: aCollection startingAt: startIndex
"Read the next elements of the receiver into aCollection.
Return aCollection or a partial copy if less than aCollection
size elements have been read."
^self next: (aCollection size - startIndex+1) into: aCollection startingAt: startIndex.!
----- Method: PositionableStream>>nextLine (in category 'accessing') -----
nextLine
"Answer next line (may be empty), or nil if at end"
self atEnd ifTrue: [^nil].
^self upTo: Character cr!
----- Method: PositionableStream>>nextLittleEndianNumber: (in category 'nonhomogeneous accessing') -----
nextLittleEndianNumber: n
"Answer the next n bytes as a positive Integer or LargePositiveInteger, where the bytes are ordered from least significant to most significant."
| bytes s |
bytes _ self next: n.
s _ 0.
n to: 1 by: -1 do: [:i | s _ (s bitShift: 8) bitOr: (bytes at: i)].
^ s
!
----- Method: PositionableStream>>nextLittleEndianNumber:put: (in category 'nonhomogeneous accessing') -----
nextLittleEndianNumber: n put: value
"Answer the next n bytes as a positive Integer or LargePositiveInteger, where the bytes are ordered from least significant to most significant."
| bytes |
bytes _ ByteArray new: n.
1 to: n do: [: i | bytes at: i put: (value digitAt: i)].
self nextPutAll: bytes!
----- Method: PositionableStream>>nextNumber: (in category 'nonhomogeneous accessing') -----
nextNumber: n
"Answer the next n bytes as a positive Integer or LargePositiveInteger."
| s |
s _ 0.
1 to: n do:
[:i | s _ (s bitShift: 8) bitOr: self next asInteger].
^ s normalize!
----- Method: PositionableStream>>nextNumber:put: (in category 'nonhomogeneous accessing') -----
nextNumber: n put: v
"Append to the receiver the argument, v, which is a positive
SmallInteger or a LargePositiveInteger, as the next n bytes.
Possibly pad with leading zeros."
1 to: n do: [:i | self nextPut: (v digitAt: n+1-i)].
^ v
!
----- Method: PositionableStream>>nextString (in category 'nonhomogeneous accessing') -----
nextString
"Read a string from the receiver. The first byte is the length of the string, unless it is greater than 192, in which case the first four bytes encode the length. I expect to be in ascii mode when called (caller puts back to binary)."
| length aByteArray |
"read the length in binary mode"
self binary.
length _ self next. "first byte."
length >= 192 ifTrue: [length _ length - 192.
1 to: 3 do: [:ii | length _ length * 256 + self next]].
aByteArray _ ByteArray new: length.
self nextInto: aByteArray.
^aByteArray asString.
!
----- Method: PositionableStream>>nextStringOld (in category 'nonhomogeneous accessing') -----
nextStringOld
"Read a string from the receiver. The first byte is the length of the
string, unless it is greater than 192, in which case the first *two* bytes
encode the length. Max size 16K. "
| aString length |
length _ self next. "first byte."
length >= 192 ifTrue: [length _ (length - 192) * 256 + self next].
aString _ String new: length.
1 to: length do: [:ii | aString at: ii put: self next asCharacter].
^aString!
----- Method: PositionableStream>>nextStringPut: (in category 'nonhomogeneous accessing') -----
nextStringPut: s
"Append the string, s, to the receiver. Only used by DataStream. Max size of 64*256*256*256."
| length |
(length _ s size) < 192
ifTrue: [self nextPut: length]
ifFalse:
[self nextPut: (length digitAt: 4)+192.
self nextPut: (length digitAt: 3).
self nextPut: (length digitAt: 2).
self nextPut: (length digitAt: 1)].
self nextPutAll: s asByteArray.
^s!
----- Method: PositionableStream>>nextWord (in category 'nonhomogeneous accessing') -----
nextWord
"Answer the next two bytes from the receiver as an Integer."
| high low |
high _ self next.
high==nil ifTrue: [^false].
low _ self next.
low==nil ifTrue: [^false].
^(high asInteger bitShift: 8) + low asInteger!
----- Method: PositionableStream>>nextWordPut: (in category 'nonhomogeneous accessing') -----
nextWordPut: aWord
"Append to the receiver an Integer as the next two bytes."
self nextPut: ((aWord bitShift: -8) bitAnd: 255).
self nextPut: (aWord bitAnd: 255).
^aWord!
----- Method: PositionableStream>>nextWordsInto: (in category 'accessing') -----
nextWordsInto: aBitmap
"Fill the word based buffer from my collection.
Stored on stream as Big Endian. Optimized for speed.
Read in BigEndian, then restoreEndianness."
| blt pos source byteSize |
collection class isBytes
ifFalse: [^ self next: aBitmap size into: aBitmap startingAt: 1].
byteSize := aBitmap byteSize.
"is the test on collection basicSize \\ 4 necessary?"
((self position bitAnd: 3) = 0 and: [ (collection basicSize bitAnd: 3) = 0])
ifTrue: [source := collection.
pos := self position.
self skip: byteSize]
ifFalse: ["forced to copy it into a buffer"
source := self next: byteSize.
pos := 0].
"Now use BitBlt to copy the bytes to the bitmap."
blt := (BitBlt current
toForm: (Form new hackBits: aBitmap))
sourceForm: (Form new hackBits: source).
blt combinationRule: Form over. "store"
blt sourceX: 0;
sourceY: pos // 4;
height: byteSize // 4;
width: 4.
blt destX: 0;
destY: 0.
blt copyBits.
"And do whatever the bitmap needs to do to convert from big-endian order."
aBitmap restoreEndianness.
^ aBitmap "May be WordArray, ColorArray, etc"
!
----- Method: PositionableStream>>on: (in category 'private') -----
on: aCollection
collection _ aCollection.
readLimit _ aCollection size.
position _ 0.
self reset!
----- Method: PositionableStream>>originalContents (in category 'accessing') -----
originalContents
"Answer the receiver's actual contents collection, NOT a copy. 1/29/96 sw"
^ collection!
----- Method: PositionableStream>>padTo:put: (in category 'positioning') -----
padTo: nBytes put: aCharacter
"Pad using the argument, aCharacter, to the next boundary of nBytes characters."
| rem |
rem _ nBytes - (self position \\ nBytes).
rem = nBytes ifTrue: [^ 0].
self next: rem put: aCharacter.!
----- Method: PositionableStream>>padToNextLongPut: (in category 'positioning') -----
padToNextLongPut: char
"Make position be on long word boundary, writing the padding
character, char, if necessary."
[self position \\ 4 = 0]
whileFalse: [self nextPut: char]!
----- Method: PositionableStream>>parseLangTagFor: (in category 'fileIn/Out') -----
parseLangTagFor: aString
| string peek runsRaw pos |
string _ aString.
"Test for ]lang[ tag"
pos _ self position.
peek _ self skipSeparatorsAndPeekNext.
peek = $] ifFalse: [self position: pos. ^ string]. "no tag"
(self upTo: $[) = ']lang' ifTrue: [
runsRaw _ self basicNextChunk.
string _ self decodeString: aString andRuns: runsRaw
] ifFalse: [
self position: pos
].
^ string.
!
----- Method: PositionableStream>>peek (in category 'accessing') -----
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!
----- Method: PositionableStream>>peekBack (in category 'accessing') -----
peekBack
"Return the element at the previous position, without changing position. Use indirect messages in case self is a StandardFileStream."
| element |
element _ self back.
self skip: 1.
^ element!
----- Method: PositionableStream>>peekFor: (in category 'accessing') -----
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!
----- Method: PositionableStream>>position (in category 'positioning') -----
position
"Answer the current position of accessing the sequence of objects."
^position!
----- Method: PositionableStream>>position: (in category 'positioning') -----
position: anInteger
"Set the current position for accessing the objects to be anInteger, as long
as anInteger is within the bounds of the receiver's contents. If it is not,
create an error notification."
anInteger >= 0 & (anInteger <= readLimit)
ifTrue: [position _ anInteger]
ifFalse: [self positionError]!
----- Method: PositionableStream>>positionError (in category 'private') -----
positionError
"Since I am not necessarily writable, it is up to my subclasses to override
position: if expanding the collection is preferrable to giving this error."
self error: 'Attempt to set the position of a PositionableStream out of bounds'!
----- Method: PositionableStream>>positionOfSubCollection: (in category 'positioning') -----
positionOfSubCollection: subCollection
"Return a position such that that element at the new position equals the first element of sub, and the next elements equal the rest of the elements of sub. Begin the search at the current position.
If no such match is found, answer 0."
^self positionOfSubCollection: subCollection ifAbsent: [0]!
----- Method: PositionableStream>>positionOfSubCollection:ifAbsent: (in category 'positioning') -----
positionOfSubCollection: subCollection ifAbsent: exceptionBlock
"Return a position such that that element at the new position equals the first element of sub, and the next elements equal the rest of the elements of sub. Begin the search at the current position.
If no such match is found, answer the result of evaluating argument, exceptionBlock."
| pattern startPosition currentPosition |
pattern _ ReadStream on: subCollection.
startPosition := self position.
[pattern atEnd] whileFalse:
[self atEnd ifTrue: [^exceptionBlock value].
self next = pattern next
ifFalse: [pattern reset]].
currentPosition := self position.
self position: startPosition.
^pattern atEnd
ifTrue: [currentPosition + 1 - subCollection size]
ifFalse: [exceptionBlock value]!
----- Method: PositionableStream>>pushBack: (in category 'positioning') -----
pushBack: aString
"Compatibility with SocketStreams"
self skip: aString size negated!
----- Method: PositionableStream>>reset (in category 'positioning') -----
reset
"Set the receiver's position to the beginning of the sequence of objects."
position _ 0!
----- Method: PositionableStream>>resetContents (in category 'positioning') -----
resetContents
"Set the position and limits to 0."
position _ 0.
readLimit _ 0!
----- Method: PositionableStream>>setFrom:to: (in category 'private') -----
setFrom: newStart to: newStop
position _ newStart - 1.
readLimit _ newStop!
----- Method: PositionableStream>>setToEnd (in category 'positioning') -----
setToEnd
"Set the position of the receiver to the end of the sequence of objects."
position _ readLimit!
----- Method: PositionableStream>>skip: (in category 'positioning') -----
skip: anInteger
"Set the receiver's position to be the current position+anInteger. A
subclass might choose to be more helpful and select the minimum of the
receiver's size and position+anInteger, or the maximum of 1 and
position+anInteger for the repositioning."
self position: position + anInteger!
----- Method: PositionableStream>>skipSeparators (in category 'fileIn/Out') -----
skipSeparators
[self atEnd]
whileFalse:
[self next isSeparator ifFalse: [^ self position: self position-1]]!
----- Method: PositionableStream>>skipSeparatorsAndPeekNext (in category 'fileIn/Out') -----
skipSeparatorsAndPeekNext
"A special function to make nextChunk fast"
| peek |
[self atEnd]
whileFalse:
[(peek _ self next) isSeparator
ifFalse: [self position: self position-1. ^ peek]]!
----- Method: PositionableStream>>skipStyleChunk (in category 'fileIn/Out') -----
skipStyleChunk
"Get to the start of the next chunk that is not a style for the previous chunk"
| pos |
pos _ self position.
self skipSeparators.
self peek == $]
ifTrue: [(self upTo: $[) = ']text' "old -- no longer needed"
"now positioned past the open bracket"
ifFalse: [self nextChunk]] "absorb ]style[ and its whole chunk"
ifFalse: [self position: pos] "leave untouched"
!
----- Method: PositionableStream>>skipTo: (in category 'positioning') -----
skipTo: anObject
"Set the access position of the receiver to be past the next occurrence of
anObject. Answer whether anObject is found."
[self atEnd]
whileFalse: [self next = anObject ifTrue: [^true]].
^false!
----- Method: PositionableStream>>string (in category 'data get/put') -----
string
"Answer the next string from this (binary) stream."
| size |
size _ self uint16.
^ (self next: size) asString
!
----- Method: PositionableStream>>string: (in category 'data get/put') -----
string: aString
"Store the given string on this (binary) stream. The string must contain 65535 or fewer characters."
aString size > 16rFFFF ifTrue: [self error: 'string too long for this format'].
self uint16: aString size.
self nextPutAll: aString asByteArray.
!
----- Method: PositionableStream>>trailer (in category 'fileIn/Out') -----
trailer
"If the stream requires a standard trailer, override this message. See HtmlFileStream"!
----- Method: PositionableStream>>uint16 (in category 'data get/put') -----
uint16
"Answer the next unsigned, 16-bit integer from this (binary) stream."
| n |
n _ self next.
n _ (n bitShift: 8) + (self next).
^ n
!
----- Method: PositionableStream>>uint16: (in category 'data get/put') -----
uint16: anInteger
"Store the given unsigned, 16-bit integer on this (binary) stream."
(anInteger < 0) | (anInteger >= 16r10000)
ifTrue: [self error: 'outside unsigned 16-bit integer range'].
self nextPut: (anInteger digitAt: 2).
self nextPut: (anInteger digitAt: 1).
!
----- Method: PositionableStream>>uint24 (in category 'data get/put') -----
uint24
"Answer the next unsigned, 24-bit integer from this (binary) stream."
| n |
n _ self next.
n _ (n bitShift: 8) + self next.
n _ (n bitShift: 8) + self next.
^ n
!
----- Method: PositionableStream>>uint24: (in category 'data get/put') -----
uint24: anInteger
"Store the given unsigned, 24-bit integer on this (binary) stream."
(anInteger < 0) | (anInteger >= 16r1000000)
ifTrue: [self error: 'outside unsigned 24-bit integer range'].
self nextPut: (anInteger digitAt: 3).
self nextPut: (anInteger digitAt: 2).
self nextPut: (anInteger digitAt: 1).
!
----- Method: PositionableStream>>uint32 (in category 'data get/put') -----
uint32
"Answer the next unsigned, 32-bit integer from this (binary) stream."
| n |
n _ self next.
n _ (n bitShift: 8) + self next.
n _ (n bitShift: 8) + self next.
n _ (n bitShift: 8) + self next.
^ n
!
----- Method: PositionableStream>>uint32: (in category 'data get/put') -----
uint32: anInteger
"Store the given unsigned, 32-bit integer on this (binary) stream."
(anInteger < 0) | (anInteger >= 16r100000000)
ifTrue: [self error: 'outside unsigned 32-bit integer range'].
self nextPut: (anInteger digitAt: 4).
self nextPut: (anInteger digitAt: 3).
self nextPut: (anInteger digitAt: 2).
self nextPut: (anInteger digitAt: 1).
!
----- Method: PositionableStream>>unCommand (in category 'fileIn/Out') -----
unCommand
"If this read stream is at a <, then skip up to just after the next >. For removing html commands."
| char |
[self peek = $<] whileTrue: ["begin a block"
[self atEnd == false and: [self next ~= $>]] whileTrue.
"absorb characters"
].
!
----- Method: PositionableStream>>untilEndWithFork:displayingProgress: (in category 'positioning') -----
untilEndWithFork: aBlock displayingProgress: aString
| sem done result |
sem := Semaphore new.
done := false.
[[result := aBlock value]
ensure: [done := true.
sem signal]] fork.
self
untilEnd: [done
ifTrue: [^ result].
(Delay forSeconds: 0.2) wait]
displayingProgress: aString.
sem wait.
^ result!
----- Method: PositionableStream>>upTo: (in category 'accessing') -----
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).
[self atEnd or: [(element _ self next) = anObject]]
whileFalse: [newStream nextPut: element].
^newStream contents!
----- Method: PositionableStream>>upToAll: (in category 'accessing') -----
upToAll: aCollection
"Answer a subcollection from the current access position to the occurrence (if any, but not inclusive) of aCollection. If aCollection is not in the stream, answer the entire rest of the stream."
| startPos endMatch result |
startPos _ self position.
(self match: aCollection)
ifTrue: [endMatch _ self position.
self position: startPos.
result _ self next: endMatch - startPos - aCollection size.
self position: endMatch.
^ result]
ifFalse: [self position: startPos.
^ self upToEnd]!
----- Method: PositionableStream>>upToEnd (in category 'accessing') -----
upToEnd
"Answer a subcollection from the current access position through the last element of the receiver."
| newStream |
newStream _ WriteStream on: (collection species new: 100).
[self atEnd] whileFalse: [ newStream nextPut: self next ].
^ newStream contents!
----- Method: PositionableStream>>verbatim: (in category 'fileIn/Out') -----
verbatim: aString
"Do not attempt to translate the characters. Use to override nextPutAll:"
^ self nextPutAll: aString!
PositionableStream subclass: #ReadStream
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Streams'!
!ReadStream commentStamp: '<historical>' prior: 0!
I represent an accessor for a sequence of objects that can only read objects from the sequence.!
----- Method: ReadStream class>>on:from:to: (in category 'instance creation') -----
on: aCollection from: firstIndex to: lastIndex
"Answer with a new instance streaming over a copy of aCollection from
firstIndex to lastIndex."
^self basicNew
on: aCollection
from: firstIndex
to: lastIndex!
----- Method: ReadStream>>ascii (in category 'accessing') -----
ascii!
----- Method: ReadStream>>binary (in category 'accessing') -----
binary!
----- Method: ReadStream>>localName (in category 'file stream compatibility') -----
localName
^'ReadStream'!
----- Method: ReadStream>>next (in category 'accessing') -----
next
"Primitive. Answer the next object in the Stream represented by the
receiver. Fail if the collection of this stream is not an Array or a String.
Fail if the stream is positioned at its end, or if the position is out of
bounds in the collection. Optional. See Object documentation
whatIsAPrimitive."
<primitive: 65>
position >= readLimit
ifTrue: [^nil]
ifFalse: [^collection at: (position _ position + 1)]!
----- Method: ReadStream>>next: (in category 'accessing') -----
next: anInteger
"Answer the next anInteger elements of my collection. overriden for efficiency"
| ans endPosition |
endPosition _ position + anInteger min: readLimit.
ans _ collection copyFrom: position+1 to: endPosition.
position _ endPosition.
^ans
!
----- Method: ReadStream>>next:into:startingAt: (in category 'accessing') -----
next: n into: aCollection startingAt: startIndex
"Read n objects into the given collection.
Return aCollection or a partial copy if less than
n elements have been read."
| max |
max _ (readLimit - position) min: n.
aCollection
replaceFrom: startIndex
to: startIndex+max-1
with: collection
startingAt: position+1.
position _ position + max.
max = n
ifTrue:[^aCollection]
ifFalse:[^aCollection copyFrom: 1 to: startIndex+max-1]!
----- Method: ReadStream>>nextPut: (in category 'accessing') -----
nextPut: anObject
self shouldNotImplement!
----- Method: ReadStream>>on:from:to: (in category 'private') -----
on: aCollection from: firstIndex to: lastIndex
| len |
collection _ aCollection.
readLimit _ lastIndex > (len _ collection size)
ifTrue: [len]
ifFalse: [lastIndex].
position _ firstIndex <= 1
ifTrue: [0]
ifFalse: [firstIndex - 1]!
----- Method: ReadStream>>openReadOnly (in category 'file stream compatibility') -----
openReadOnly!
----- Method: ReadStream>>readOnly (in category 'file stream compatibility') -----
readOnly!
----- Method: ReadStream>>readStream (in category 'accessing') -----
readStream
"polymorphic with SequenceableCollection. Return self"
^ self!
----- Method: ReadStream>>size (in category 'accessing') -----
size
"Compatibility with other streams (e.g., FileStream)"
^readLimit!
----- Method: ReadStream>>upTo: (in category 'accessing') -----
upTo: anObject
"fast version using indexOf:"
| start end |
start _ position+1.
end _ collection indexOf: anObject startingAt: start ifAbsent: [ 0 ].
"not present--return rest of the collection"
end = 0 ifTrue: [ ^self upToEnd ].
"skip to the end and return the data passed over"
position _ end.
^collection copyFrom: start to: (end-1)!
----- Method: ReadStream>>upToEnd (in category 'accessing') -----
upToEnd
| start |
start _ position+1.
position _ collection size.
^collection copyFrom: start to: position!
PositionableStream subclass: #WriteStream
instanceVariableNames: 'writeLimit'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Streams'!
!WriteStream commentStamp: '<historical>' prior: 0!
I represent an accessor for a sequence of objects that can only store objects in the sequence.!
WriteStream subclass: #LimitedWriteStream
instanceVariableNames: 'limit limitBlock'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Streams'!
!LimitedWriteStream commentStamp: '<historical>' prior: 0!
A LimitedWriteStream is a specialized WriteStream that has a maximum size of the collection it streams over. When this limit is reached a special limitBlock is executed. This can for example be used to "bail out" of lengthy streaming operations before they have finished. For a simple example take a look at the universal Object printString.
The message SequenceableCollection class streamContents:limitedTo: creates a LimitedWriteStream. In this case it prevents very large (or possibly recursive) object structures to "overdo" their textual representation. !
----- Method: LimitedWriteStream>>nextPut: (in category 'accessing') -----
nextPut: anObject
"Ensure that the limit is not exceeded"
position >= limit ifTrue: [limitBlock value]
ifFalse: [super nextPut: anObject].
!
----- Method: LimitedWriteStream>>nextPutAll: (in category 'as yet unclassified') -----
nextPutAll: aCollection
| newEnd |
collection class == aCollection class ifFalse:
[^ super nextPutAll: aCollection ].
newEnd _ position + aCollection size.
newEnd > limit ifTrue: [
super nextPutAll: (aCollection copyFrom: 1 to: (limit - position max: 0)).
^ limitBlock value.
].
newEnd > writeLimit ifTrue: [
self growTo: newEnd + 10
].
collection replaceFrom: position+1 to: newEnd with: aCollection startingAt: 1.
position _ newEnd.!
----- Method: LimitedWriteStream>>pastEndPut: (in category 'as yet unclassified') -----
pastEndPut: anObject
collection size >= limit ifTrue: [limitBlock value]. "Exceptional return"
^ super pastEndPut: anObject!
----- Method: LimitedWriteStream>>setLimit:limitBlock: (in category 'as yet unclassified') -----
setLimit: sizeLimit limitBlock: aBlock
"Limit the numer of elements this stream will write..."
limit _ sizeLimit.
"Execute this (typically ^ contents) when that limit is exceded"
limitBlock _ aBlock!
WriteStream subclass: #ReadWriteStream
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Streams'!
!ReadWriteStream commentStamp: '<historical>' prior: 0!
I represent an accessor for a sequence of objects. My instances can both read and store objects.!
ReadWriteStream subclass: #RWBinaryOrTextStream
instanceVariableNames: 'isBinary'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Streams'!
!RWBinaryOrTextStream commentStamp: '<historical>' prior: 0!
A simulation of a FileStream, but living totally in memory. Hold the contents of a file or web page from the network. Can then fileIn like a normal FileStream.
Need to be able to switch between binary and text, as a FileStream does, without recopying the whole collection. Convert to binary upon input and output. Always keep as text internally.!
----- Method: RWBinaryOrTextStream>>asBinaryOrTextStream (in category 'as yet unclassified') -----
asBinaryOrTextStream
^ self!
----- Method: RWBinaryOrTextStream>>ascii (in category 'as yet unclassified') -----
ascii
isBinary _ false!
----- Method: RWBinaryOrTextStream>>binary (in category 'as yet unclassified') -----
binary
isBinary _ true!
----- Method: RWBinaryOrTextStream>>contents (in category 'as yet unclassified') -----
contents
"Answer with a copy of my collection from 1 to readLimit."
| newArray |
isBinary ifFalse: [^ super contents]. "String"
readLimit _ readLimit max: position.
newArray _ ByteArray new: readLimit.
^ newArray replaceFrom: 1
to: readLimit
with: collection
startingAt: 1.!
----- Method: RWBinaryOrTextStream>>contentsOfEntireFile (in category 'as yet unclassified') -----
contentsOfEntireFile
"For compatibility with file streams."
^ self contents!
----- Method: RWBinaryOrTextStream>>isBinary (in category 'as yet unclassified') -----
isBinary
^ isBinary!
----- Method: RWBinaryOrTextStream>>next (in category 'as yet unclassified') -----
next
| byte |
^ isBinary
ifTrue: [byte _ super next.
byte ifNil: [nil] ifNotNil: [byte asciiValue]]
ifFalse: [super next].
!
----- Method: RWBinaryOrTextStream>>next: (in category 'as yet unclassified') -----
next: anInteger
"Answer the next anInteger elements of my collection. Must override to get class right."
| newArray |
newArray _ (isBinary ifTrue: [ByteArray] ifFalse: [ByteString]) new: anInteger.
^ self nextInto: newArray!
----- Method: RWBinaryOrTextStream>>next:into:startingAt: (in category 'as yet unclassified') -----
next: n into: aCollection startingAt: startIndex
"Read n objects into the given collection.
Return aCollection or a partial copy if less than n elements have been read."
"Overriden for efficiency"
| max |
max _ (readLimit - position) min: n.
aCollection
replaceFrom: startIndex
to: startIndex+max-1
with: collection
startingAt: position+1.
position _ position + max.
max = n
ifTrue:[^aCollection]
ifFalse:[^aCollection copyFrom: 1 to: startIndex+max-1]!
----- Method: RWBinaryOrTextStream>>next:putAll:startingAt: (in category 'writing') -----
next: anInteger putAll: aCollection startingAt: startIndex
^super next: anInteger putAll: aCollection asString startingAt: startIndex!
----- Method: RWBinaryOrTextStream>>nextPut: (in category 'as yet unclassified') -----
nextPut: charOrByte
super nextPut: charOrByte asCharacter!
----- Method: RWBinaryOrTextStream>>nextPutAll: (in category 'writing') -----
nextPutAll: aCollection
^super nextPutAll: aCollection asString!
----- Method: RWBinaryOrTextStream>>padToEndWith: (in category 'as yet unclassified') -----
padToEndWith: aChar
"We don't have pages, so we are at the end, and don't need to pad."!
----- Method: RWBinaryOrTextStream>>reset (in category 'as yet unclassified') -----
reset
"Set the receiver's position to the beginning of the sequence of objects."
super reset.
isBinary ifNil: [isBinary _ false].
collection class == ByteArray ifTrue: ["Store as String and convert as needed."
collection _ collection asString.
isBinary _ true].
!
----- Method: RWBinaryOrTextStream>>setFileTypeToObject (in category 'as yet unclassified') -----
setFileTypeToObject
"do nothing. We don't have a file type"!
----- Method: RWBinaryOrTextStream>>text (in category 'as yet unclassified') -----
text
isBinary _ false!
----- Method: RWBinaryOrTextStream>>upToEnd (in category 'as yet unclassified') -----
upToEnd
"Must override to get class right."
| newArray |
newArray _ (isBinary ifTrue: [ByteArray] ifFalse: [ByteString]) new: self size - self position.
^ self nextInto: newArray!
----- Method: ReadWriteStream>>= (in category 'testing') -----
= other
(self class == ReadWriteStream and: [other class == ReadWriteStream]) ifFalse: [
^ super = other]. "does an identity test. Don't read contents of FileStream"
^ self position = other position and: [self contents = other contents]!
----- Method: ReadWriteStream>>asUnZippedStream (in category 'converting') -----
asUnZippedStream
| isGZip outputStream first strm archive which |
"Decompress this file if needed, and return a stream. No file is written. File extension may be .gz or anything else. Also works on archives (.zip, .gZip)."
strm _ self binary.
strm isZipArchive ifTrue: [
archive _ ZipArchive new readFrom: strm.
which _ archive members detect: [:any | any fileName asLowercase endsWith: '.ttf']
ifNone: [nil].
which ifNil: [archive close.
^ self error: 'Can''t find .ttf file in archive'].
strm _ which contentStream.
archive close].
first _ strm next.
isGZip _ (strm next * 256 + first) = (GZipConstants gzipMagic).
strm skip: -2.
isGZip
ifTrue: [outputStream _ (MultiByteBinaryOrTextStream with:
(GZipReadStream on: strm) upToEnd) reset.
strm close]
ifFalse: [outputStream _ strm].
^ outputStream!
----- Method: ReadWriteStream>>close (in category 'file status') -----
close
"Presumably sets the status of the receiver to be closed. This message does
nothing at this level, but is included for FileStream compatibility."
^self!
----- Method: ReadWriteStream>>closed (in category 'file status') -----
closed
"If you have close (for FileStream compatibility), you must respond to closed. The result in nonsense here. TK 29 May 96"
^ false!
----- Method: ReadWriteStream>>contents (in category 'accessing') -----
contents
"Answer with a copy of my collection from 1 to readLimit."
readLimit _ readLimit max: position.
^collection copyFrom: 1 to: readLimit!
----- Method: ReadWriteStream>>fileInObjectAndCode (in category 'fileIn/Out') -----
fileInObjectAndCode
"This file may contain:
1) a fileIn of code
2) just an object in SmartReferenceStream format
3) both code and an object.
File it in and return the object. Note that self must be a FileStream or RWBinaryOrTextStream. Maybe ReadWriteStream incorporate RWBinaryOrTextStream?"
| refStream object |
self text.
self peek asciiValue = 4
ifTrue: [ "pure object file"
refStream _ SmartRefStream on: self.
object _ refStream nextAndClose]
ifFalse: [ "objects mixed with a fileIn"
self fileIn. "reads code and objects, then closes the file"
object _ SmartRefStream scannedObject]. "set by side effect of one of the chunks"
SmartRefStream scannedObject: nil. "clear scannedObject"
^ object!
----- Method: ReadWriteStream>>fileNameEndsWith: (in category 'fileIn/Out') -----
fileNameEndsWith: aString
"See comment in FileStream fileNameEndsWith:"
^false!
----- Method: ReadWriteStream>>fileOutChangeSet:andObject: (in category 'fileIn/Out') -----
fileOutChangeSet: aChangeSetOrNil andObject: theObject
^ self fileOutChangeSet: aChangeSetOrNil andObject: theObject withVersionNotification: false.
!
----- Method: ReadWriteStream>>fileOutChangeSet:andObject:withVersionNotification: (in category 'fileIn/Out') -----
fileOutChangeSet: aChangeSetOrNil andObject: theObject withVersionNotification: withNotification
"Write a file that has both the source code for the named class and an object as bits. Any instance-specific object will get its class written automatically."
"An experimental version to fileout a changeSet first so that a project can contain its own classes"
self setFileTypeToObject.
"Type and Creator not to be text, so can attach correctly to an email msg"
self header; timeStamp.
(withNotification or: [aChangeSetOrNil notNil]) ifTrue: [
withNotification ifTrue: [
self fileOutVersionCheckNotification.
].
aChangeSetOrNil ifNotNil: [
aChangeSetOrNil fileOutPreambleOn: self.
aChangeSetOrNil fileOutOn: self.
aChangeSetOrNil fileOutPostscriptOn: self.
].
].
self trailer. "Does nothing for normal files. HTML streams will have trouble with object data"
"Append the object's raw data"
(SmartRefStream on: self)
nextPut: theObject; "and all subobjects"
close. "also closes me"
!
----- Method: ReadWriteStream>>fileOutChanges (in category 'fileIn/Out') -----
fileOutChanges
"Append to the receiver a description of all class changes."
Cursor write showWhile:
[self header; timeStamp.
ChangeSet current fileOutOn: self.
self trailer; close]!
----- Method: ReadWriteStream>>fileOutClass:andObject: (in category 'fileIn/Out') -----
fileOutClass: extraClass andObject: theObject
"Write a file that has both the source code for the named class and an object as bits. Any instance-specific object will get its class written automatically."
| class srefStream |
self setFileTypeToObject.
"Type and Creator not to be text, so can attach correctly to an email msg"
self text.
self header; timeStamp.
extraClass ifNotNil: [
class _ extraClass. "A specific class the user wants written"
class sharedPools size > 0 ifTrue:
[class shouldFileOutPools
ifTrue: [class fileOutSharedPoolsOn: self]].
class fileOutOn: self moveSource: false toFile: 0].
self trailer. "Does nothing for normal files. HTML streams will have trouble with object data"
self binary.
"Append the object's raw data"
srefStream _ SmartRefStream on: self.
srefStream nextPut: theObject. "and all subobjects"
srefStream close. "also closes me"
!
----- Method: ReadWriteStream>>fileOutClass:andObject:blocking: (in category 'fileIn/Out') -----
fileOutClass: extraClass andObject: theObject blocking: anIdentDict
"Write a file that has both the source code for the named class and an object as bits. Any instance-specific object will get its class written automatically. Accept a list of objects to map to nil or some other object (blockers). In addition to teh choices in each class's objectToStoreOnDataStream"
| class srefStream |
self setFileTypeToObject.
"Type and Creator not to be text, so can attach correctly to an email msg"
self header; timeStamp.
extraClass ifNotNil: [
class _ extraClass. "A specific class the user wants written"
class sharedPools size > 0 ifTrue:
[class shouldFileOutPools
ifTrue: [class fileOutSharedPoolsOn: self]].
class fileOutOn: self moveSource: false toFile: 0].
self trailer. "Does nothing for normal files. HTML streams will have trouble with object data"
"Append the object's raw data"
srefStream _ SmartRefStream on: self.
srefStream blockers: anIdentDict.
srefStream nextPut: theObject. "and all subobjects"
srefStream close. "also closes me"
!
----- Method: ReadWriteStream>>fileOutVersionCheckNotification (in category 'fileIn/Out') -----
fileOutVersionCheckNotification
"Put a version-check bumper onto the project stream."
self nextChunkPut: ' | cont | (Smalltalk includesKey: #MorphExtensionPlus) ifFalse: [self inform: ''This project cannot be loaded into an older system.\Please use an OLPC Etoys compatible image.'' translated withCRs.
cont _ thisContext.
[cont notNil] whileTrue: [
cont selector == #handleEvent: ifTrue: [cont return: nil].
cont _ cont sender.
]]'; cr.
self nextChunkPut: ' | cont | (Smalltalk includesKey: #CalendarMorph) ifFalse:
[(self confirm: ''This project was created from a more recent\version of Etoys, and may not load or\work properly in an older system.\Ideally use Etoys 5.0 or newer\proceed anyway?'' translated withCRs) ifFalse:
[cont _ thisContext.
[cont notNil] whileTrue: [
cont selector == #handleEvent: ifTrue: [cont return: nil].
cont _ cont sender.
]]]'; cr.
!
----- Method: ReadWriteStream>>hash (in category 'testing') -----
hash
self class == ReadWriteStream ifFalse: [^ super hash].
^ (self position + readLimit + 53) hash!
----- Method: ReadWriteStream>>isZipArchive (in category 'testing') -----
isZipArchive
"Determine if this appears to be a valid Zip archive"
| sig |
self binary.
sig _ self next: 4.
self position: self position - 4. "rewind"
^ZipArchive validSignatures includes: sig!
----- Method: ReadWriteStream>>name (in category 'accessing') -----
name
^ 'a stream' translated "for fileIn compatibility"!
----- Method: ReadWriteStream>>next (in category 'accessing') -----
next
"Primitive. Return the next object in the Stream represented by the
receiver. Fail if the collection of this stream is not an Array or a String.
Fail if the stream is positioned at its end, or if the position is out of
bounds in the collection. Optional. See Object documentation
whatIsAPrimitive."
<primitive: 65>
"treat me as a FIFO"
position >= readLimit
ifTrue: [^nil]
ifFalse: [^collection at: (position _ position + 1)]!
----- Method: ReadWriteStream>>next: (in category 'accessing') -----
next: anInteger
"Answer the next anInteger elements of my collection. overriden for efficiency"
| ans endPosition |
readLimit := readLimit max: position.
endPosition _ position + anInteger min: readLimit.
ans _ collection copyFrom: position+1 to: endPosition.
position _ endPosition.
^ans
!
----- Method: ReadWriteStream>>readStream (in category 'converting') -----
readStream
"polymorphic with SequenceableCollection. Return self"
^ self!
ReadWriteStream subclass: #Transcripter
instanceVariableNames: 'frame para'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Streams'!
!Transcripter commentStamp: '<historical>' prior: 0!
Transcripter is a dog-simple scrolling stream with display. It is intended to operate with no support from MVC or color in a minimal, or headless version of Squeak. No attention has been paid to appearance or performance.!
----- Method: Transcripter class>>emergencyEvaluator (in category 'utilities') -----
emergencyEvaluator
(Transcripter newInFrame: (0 at 0 corner: 320 at 200))
show: 'Type ''revert'' to revert your last method change.
Type ''exit'' to exit the emergency evaluator.';
readEvalPrint!
----- Method: Transcripter class>>newInFrame: (in category 'instance creation') -----
newInFrame: frame
"
(Transcripter newInFrame: (0 at 0 extent: 100 at 200))
nextPutAll: 'Hello there'; endEntry;
cr; print: 355.0/113; endEntry;
readEvalPrint.
"
| transcript |
transcript _ self on: (String new: 100).
transcript initInFrame: frame.
^ transcript clear!
----- Method: Transcripter class>>startTranscriptProcess (in category 'instance creation') -----
startTranscriptProcess "Transcripter startTranscriptProcess"
| activeProcess |
Transcript _ self newInFrame: Display boundingBox.
activeProcess _ [Transcript readEvalPrint.
Smalltalk processShutDownList: true; quitPrimitive]
newProcess
priority: Processor userSchedulingPriority.
activeProcess resume.
Processor terminateActive
!
----- Method: Transcripter>>black (in category 'private') -----
black
Display depth = 1 ifTrue: [^ Bitmap with: 16rFFFFFFFF "Works without color support"].
^ Color black!
----- Method: Transcripter>>clear (in category 'accessing') -----
clear
Display fill: (frame insetBy: -2) fillColor: self black;
fill: frame fillColor: self white.
self on: (String new: 100); endEntry!
----- Method: Transcripter>>confirm: (in category 'command line') -----
confirm: queryString
| choice |
[true]
whileTrue:
[choice _ self request: queryString , '
Please type yes or no followed by return'.
choice first asUppercase = $Y ifTrue: [^ true].
choice first asUppercase = $N ifTrue: [^ false]]!
----- Method: Transcripter>>endEntry (in category 'accessing') -----
endEntry
| c d cb |
c _ self contents.
Display extent ~= DisplayScreen actualScreenSize ifTrue:
["Handle case of user resizing physical window"
DisplayScreen startUp.
frame _ frame intersect: Display boundingBox.
^ self clear; show: c].
para setWithText: c asText
style: TextStyle default
compositionRectangle: ((frame insetBy: 4) withHeight: 9999)
clippingRectangle: frame
foreColor: self black backColor: self white.
d _ para compositionRectangle bottom - frame bottom.
d > 0 ifTrue:
["Scroll up to keep all contents visible"
cb _ para characterBlockAtPoint: para compositionRectangle topLeft
+ (0@(d+para lineGrid)).
self on: (c copyFrom: cb stringIndex to: c size).
readLimit_ position_ collection size.
^ self endEntry].
para display!
----- Method: Transcripter>>initInFrame: (in category 'initialization') -----
initInFrame: rect
frame _ rect insetBy: 2. "Leave room for border"
para _ Paragraph withText: self contents asText
style: TextStyle default
compositionRectangle: ((frame insetBy: 4) withHeight: 9999)
clippingRectangle: frame
foreColor: self black backColor: self white!
----- Method: Transcripter>>readEvalPrint (in category 'command line') -----
readEvalPrint
| line okToRevert |
okToRevert _ true.
[#('quit' 'exit' 'done' ) includes: (line _ self request: '>')]
whileFalse:
[line = 'revert'
ifTrue: [okToRevert
ifTrue: [Utilities revertLastMethodSubmission.
self cr; show: 'reverted: ' , Utilities mostRecentlySubmittedMessage.
okToRevert _ false]
ifFalse: [self cr; show: 'Only one level of revert currently supported']]
ifFalse: [self cr; show: ([Compiler evaluate: line] ifError: [:err :ex | err])]]!
----- Method: Transcripter>>request: (in category 'command line') -----
request: prompt
| startPos char contents |
self cr; show: prompt.
startPos _ position.
[[Sensor keyboardPressed] whileFalse.
(char _ Sensor keyboard) = Character cr]
whileFalse:
[char = Character backspace
ifTrue: [readLimit _ position _ (position - 1 max: startPos)]
ifFalse: [self nextPut: char].
self endEntry].
contents _ self contents.
^ contents copyFrom: startPos + 1 to: contents size!
----- Method: Transcripter>>show: (in category 'accessing') -----
show: anObject
self nextPutAll: anObject asString; endEntry!
----- Method: Transcripter>>white (in category 'private') -----
white
Display depth = 1 ifTrue: [^ Bitmap with: 0 "Works without color support"].
^ Color white!
WriteStream subclass: #TextStream
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Streams'!
----- Method: TextStream>>applyAttribute:beginningAt: (in category 'as yet unclassified') -----
applyAttribute: att beginningAt: startPos
collection addAttribute: att from: startPos to: self position!
----- Method: TextStream>>nextPutAll: (in category 'as yet unclassified') -----
nextPutAll: aCollection
"Optimized access to get around Text at:Put: overhead"
| n |
n _ aCollection size.
position + n > writeLimit
ifTrue:
[self growTo: position + n + 10].
collection
replaceFrom: position+1
to: position + n
with: aCollection
startingAt: 1.
position _ position + n!
----- Method: TextStream>>withAttribute:do: (in category 'as yet unclassified') -----
withAttribute: att do: strmBlock
| pos1 val |
pos1 _ self position.
val _ strmBlock value.
collection addAttribute: att from: pos1+1 to: self position.
^ val!
----- Method: TextStream>>withAttributes:do: (in category 'as yet unclassified') -----
withAttributes: attributes do: streamBlock
| pos1 val |
pos1 _ self position.
val _ streamBlock value.
attributes do: [:attribute |
collection
addAttribute: attribute
from: pos1 + 1
to: self position].
^ val!
WriteStream subclass: #TranscriptStream
instanceVariableNames: ''
classVariableNames: 'AccessSema'
poolDictionaries: ''
category: 'Collections-Streams'!
!TranscriptStream commentStamp: '<historical>' prior: 0!
This class is a much simpler implementation of Transcript protocol that supports multiple views and very simple conversion to morphic. Because it inherits from Stream, it is automatically compatible with code that is designe to write to streams.!
----- Method: TranscriptStream class>>initialize (in category 'class initialization') -----
initialize
self registerInFlapsRegistry. !
----- Method: TranscriptStream class>>new (in category 'as yet unclassified') -----
new
^ self on: (String new: 1000)
"
INSTALLING:
TextCollector allInstances do:
[:t | t breakDependents.
t become: TranscriptStream new].
TESTING: (Execute this text in a workspace)
Do this first...
tt _ TranscriptStream new.
tt openLabel: 'Transcript test 1'.
Then this will open a second view -- ooooh...
tt openLabel: 'Transcript test 2'.
And finally make them do something...
tt clear.
[Sensor anyButtonPressed] whileFalse:
[1 to: 20 do: [:i | tt print: (2 raisedTo: i-1); cr; endEntry]].
"!
----- Method: TranscriptStream class>>newTranscript: (in category 'as yet unclassified') -----
newTranscript: aTextCollector
"Store aTextCollector as the value of the system global Transcript."
Smalltalk at: #Transcript put: aTextCollector!
----- Method: TranscriptStream class>>openMorphicTranscript (in category 'as yet unclassified') -----
openMorphicTranscript
"Have the current project's transcript open up as a morph"
^ Transcript openAsMorph!
----- Method: TranscriptStream class>>registerInFlapsRegistry (in category 'class initialization') -----
registerInFlapsRegistry
"Register the receiver in the system's flaps registry"
self environment
at: #Flaps
ifPresent: [:cl | cl registerQuad: {#TranscriptStream. #openMorphicTranscript. 'Transcript' translatedNoop. 'A Transcript is a window usable for logging and debugging; browse references to #Transcript for examples of how to write to it.' translatedNoop}
forFlapNamed: 'Tools']
!
----- Method: TranscriptStream class>>unload (in category 'class initialization') -----
unload
"Unload the receiver from global registries"
self environment at: #Flaps ifPresent: [:cl |
cl unregisterQuadsWithReceiver: self] !
----- Method: TranscriptStream class>>windowColorSpecification (in category 'window color') -----
windowColorSpecification
"Answer a WindowColorSpec object that declares my preference"
^ WindowColorSpec classSymbol: self name wording: 'Transcript' translatedNoop brightColor: #lightOrange pastelColor: #paleOrange helpMessage: 'The system transcript' translatedNoop!
----- Method: TranscriptStream>>bs (in category 'stream extensions') -----
bs
self position > 0 ifTrue: [^ self skip: -1].
self changed: #bs!
----- Method: TranscriptStream>>characterLimit (in category 'access') -----
characterLimit
"Tell the views how much to retain on screen"
^ 20000!
----- Method: TranscriptStream>>clear (in category 'stream extensions') -----
clear
"Clear all characters and redisplay the view"
self changed: #clearText.
self reset!
----- Method: TranscriptStream>>closeAllViews (in category 'initialization') -----
closeAllViews
"Transcript closeAllViews"
self dependents do:
[:d |
(d isKindOf: PluggableTextView)
ifTrue: [d topView controller closeAndUnscheduleNoTerminate].
(d isSystemWindow) ifTrue: [d delete]]!
----- Method: TranscriptStream>>codePaneMenu:shifted: (in category 'model protocol') -----
codePaneMenu: aMenu shifted: shifted
"Note that unless we override perform:orSendTo:, PluggableTextController will respond to all menu items"
^ StringHolder basicNew codePaneMenu: aMenu shifted: shifted
!
----- Method: TranscriptStream>>countOpenTranscripts (in category 'private') -----
countOpenTranscripts
"Transcript countOpenTranscripts"
^ (self dependents select: [:e | e isTextView]) size
!
----- Method: TranscriptStream>>endEntry (in category 'stream extensions') -----
endEntry
"Display all the characters since the last endEntry, and reset the stream"
self semaphore critical:[
self changed: #appendEntry.
self reset.
].!
----- Method: TranscriptStream>>flush (in category 'stream extensions') -----
flush
self endEntry!
----- Method: TranscriptStream>>open (in category 'initialization') -----
open
| openCount |
openCount _ 0.
self dependents do:
[:d | ((d isKindOf: PluggableTextView) or:
[d isKindOf: PluggableTextMorph]) ifTrue: [openCount _ openCount + 1]].
openCount = 0
ifTrue: [self openLabel: 'Transcript']
ifFalse: [self openLabel: 'Transcript #' , (openCount+1) printString]!
----- Method: TranscriptStream>>openAsMorph (in category 'initialization') -----
openAsMorph
"Answer a morph viewing this transcriptStream"
^ (self openAsMorphLabel: 'Transcript') applyModelExtent!
----- Method: TranscriptStream>>openAsMorphLabel: (in category 'initialization') -----
openAsMorphLabel: labelString
"Build a morph viewing this transcriptStream"
| window |
window _ (SystemWindow labelled: labelString) model: self.
window addMorph: (PluggableTextMorph on: self text: nil accept: nil
readSelection: nil menu: #codePaneMenu:shifted:)
frame: (0 at 0 corner: 1 at 1).
^ window!
----- Method: TranscriptStream>>openLabel: (in category 'initialization') -----
openLabel: aString
"Open a window on this transcriptStream"
| topView codeView |
Smalltalk isMorphic ifTrue: [^ (self openAsMorphLabel: aString) openInWorld].
topView _ (StandardSystemView new) model: self.
topView borderWidth: 1.
topView label: aString.
topView minimumSize: 100 @ 50.
codeView _ PluggableTextView on: self text: nil accept: nil
readSelection: nil menu: #codePaneMenu:shifted:.
codeView window: (0 at 0 extent: 200 at 200).
topView addSubView: codeView.
topView controller open!
----- Method: TranscriptStream>>pastEndPut: (in category 'stream extensions') -----
pastEndPut: anObject
"If the stream reaches its limit, just output the contents and reset."
self endEntry.
^ self nextPut: anObject!
----- Method: TranscriptStream>>perform:orSendTo: (in category 'model protocol') -----
perform: selector orSendTo: otherTarget
"Selector was just chosen from a menu by a user. If can respond, then
perform it on myself. If not, send it to otherTarget, presumably the
editPane from which the menu was invoked."
(self respondsTo: selector)
ifTrue: [^ self perform: selector]
ifFalse: [^ otherTarget perform: selector]!
----- Method: TranscriptStream>>release (in category 'model protocol') -----
release
self dependents do:
[:view | (view isMorph and: [view isInWorld not])
ifTrue: [self removeDependent: view]]!
----- Method: TranscriptStream>>semaphore (in category 'private') -----
semaphore
^AccessSema ifNil:[AccessSema _ Semaphore forMutualExclusion]!
----- Method: TranscriptStream>>show: (in category 'stream extensions') -----
show: anObject "TextCollector compatibility"
self nextPutAll: anObject asString; endEntry!
----- Method: TranscriptStream>>step (in category 'model protocol') -----
step
"Objects that may be models of SystemWindows need to respond to this, albeit vacuously"!
----- Method: WriteStream class>>on:from:to: (in category 'instance creation') -----
on: aCollection from: firstIndex to: lastIndex
"Answer an instance of me on a copy of the argument, aCollection,
determined by the indices firstIndex and lastIndex. Position the instance
at the beginning of the collection."
^self basicNew
on: aCollection
from: firstIndex
to: lastIndex!
----- Method: WriteStream class>>with: (in category 'instance creation') -----
with: aCollection
"Answer an instance of me on the argument, aCollection, positioned to
store objects at the end of aCollection."
^self basicNew with: aCollection!
----- Method: WriteStream class>>with:from:to: (in category 'instance creation') -----
with: aCollection from: firstIndex to: lastIndex
"Answer an instance of me on the subcollection of the argument,
aCollection, determined by the indices firstIndex and lastIndex. Position
the instance to store at the end of the subcollection."
^self basicNew with: (aCollection copyFrom: firstIndex to: lastIndex)!
----- Method: WriteStream>>braceArray (in category 'private') -----
braceArray
"This method is used in compilation of brace constructs.
It MUST NOT be deleted or altered."
^ collection!
----- Method: WriteStream>>braceArray: (in category 'private') -----
braceArray: anArray
"This method is used in compilation of brace constructs.
It MUST NOT be deleted or altered."
collection _ anArray.
position _ 0.
readLimit _ 0.
writeLimit _ anArray size.!
----- Method: WriteStream>>contents (in category 'accessing') -----
contents
readLimit _ readLimit max: position.
^collection copyFrom: 1 to: position!
----- Method: WriteStream>>cr (in category 'character writing') -----
cr
"Append a return character to the receiver."
self nextPut: Character cr!
----- Method: WriteStream>>crtab (in category 'character writing') -----
crtab
"Append a return character, followed by a single tab character, to the
receiver."
self nextPut: Character cr.
self nextPut: Character tab!
----- Method: WriteStream>>crtab: (in category 'character writing') -----
crtab: anInteger
"Append a return character, followed by anInteger tab characters, to the
receiver."
self nextPut: Character cr.
anInteger timesRepeat: [self nextPut: Character tab]!
----- Method: WriteStream>>ensureASpace (in category 'character writing') -----
ensureASpace
"Append a space character to the receiver IFF there is not one on the end."
(position > 0 and: [(collection at: position) = Character space]) ifTrue: [^self].
self nextPut: Character space!
----- Method: WriteStream>>ensureNoSpace (in category 'character writing') -----
ensureNoSpace
"If there is not one on the end, remove it."
(position > 0 and: [(collection at: position) = Character space])
ifTrue: [self skip: -1].!
----- Method: WriteStream>>flush (in category 'file open/close') -----
flush!
----- Method: WriteStream>>growTo: (in category 'private') -----
growTo: anInteger
" anInteger is the required minimal new size of the collection "
| oldSize grownCollection newSize |
oldSize _ collection size.
newSize := anInteger + (oldSize // 4 max: 20).
grownCollection _ collection class new: newSize.
collection _ grownCollection replaceFrom: 1 to: oldSize with: collection startingAt: 1.
writeLimit _ collection size.
!
----- Method: WriteStream>>next (in category 'accessing') -----
next
self shouldNotImplement!
----- Method: WriteStream>>next:putAll:startingAt: (in category 'accessing') -----
next: anInteger putAll: aCollection startingAt: startIndex
"Store the next anInteger elements from the given collection."
| newEnd numPut |
collection class == aCollection class ifFalse:
[^ super next: anInteger putAll: aCollection startingAt: startIndex ].
numPut _ anInteger min: (aCollection size - startIndex + 1).
newEnd _ position + numPut.
newEnd > writeLimit ifTrue:
[^ super next: anInteger putAll: aCollection startingAt: startIndex "Trigger normal pastEndPut: logic"].
collection replaceFrom: position+1 to: newEnd with: aCollection startingAt: startIndex.
position _ newEnd.
!
----- Method: WriteStream>>nextChunkPut: (in category 'fileIn/Out') -----
nextChunkPut: aString
"Append the argument, aString, to the receiver, doubling embedded terminators."
| i remainder terminator |
terminator _ $!!.
remainder _ aString.
[(i _ remainder indexOf: terminator) = 0] whileFalse:
[self nextPutAll: (remainder copyFrom: 1 to: i).
self nextPut: terminator. "double imbedded terminators"
remainder _ remainder copyFrom: i+1 to: remainder size].
self nextPutAll: remainder.
aString includesUnifiedCharacter ifTrue: [
self nextPut: terminator.
self nextPutAll: ']lang['.
aString writeLeadingCharRunsOn: self.
].
self nextPut: terminator.
!
----- Method: WriteStream>>nextChunkPutWithStyle: (in category 'fileIn/Out') -----
nextChunkPutWithStyle: aStringOrText
"Append the argument, aText, to the receiver, doubling embedded terminators. Put out one chunk for the string and one for the style runs. Mark the style with ]style[."
aStringOrText isString ifTrue: [^ self nextChunkPut: aStringOrText].
aStringOrText runs coalesce.
aStringOrText unembellished ifTrue: [^ self nextChunkPut: aStringOrText asString].
self nextChunkPut: aStringOrText asString.
self cr; nextPutAll: ']style['.
self nextChunkPut:
(String streamContents: [:strm |
aStringOrText runs writeScanOn: strm]).
!
----- Method: WriteStream>>nextPut: (in category 'accessing') -----
nextPut: anObject
"Primitive. Insert the argument at the next position in the Stream
represented by the receiver. Fail if the collection of this stream is not an
Array or a String. Fail if the stream is positioned at its end, or if the
position is out of bounds in the collection. Fail if the argument is not
of the right type for the collection. Optional. See Object documentation
whatIsAPrimitive."
<primitive: 66>
((collection class == ByteString) and: [
anObject isCharacter and:[anObject isOctetCharacter not]]) ifTrue: [
collection _ (WideString from: collection).
^self nextPut: anObject.
].
position >= writeLimit
ifTrue: [^ self pastEndPut: anObject]
ifFalse:
[position _ position + 1.
^collection at: position put: anObject]!
----- Method: WriteStream>>nextPutAll: (in category 'accessing') -----
nextPutAll: aCollection
| newEnd |
collection class == aCollection class ifFalse:
[^ super nextPutAll: aCollection ].
newEnd _ position + aCollection size.
newEnd > writeLimit ifTrue:
[self growTo: newEnd + 10].
collection replaceFrom: position+1 to: newEnd with: aCollection startingAt: 1.
position _ newEnd.!
----- Method: WriteStream>>nextPutKeyword:withArg: (in category 'character writing') -----
nextPutKeyword: keyword withArg: argValue
"Emit a keyword/value pair in the alternate syntax"
self nextPutAll: (keyword copyWithout: $:);
nextPut: $(;
store: argValue;
nextPut: $)!
----- Method: WriteStream>>on: (in category 'private') -----
on: aCollection
super on: aCollection.
readLimit _ 0.
writeLimit _ aCollection size!
----- Method: WriteStream>>on:from:to: (in category 'private') -----
on: aCollection from: firstIndex to: lastIndex
| len |
collection _ aCollection.
readLimit _
writeLimit _ lastIndex > (len _ collection size)
ifTrue: [len]
ifFalse: [lastIndex].
position _ firstIndex <= 1
ifTrue: [0]
ifFalse: [firstIndex - 1]!
----- Method: WriteStream>>pastEndPut: (in category 'private') -----
pastEndPut: anObject
"Grow the collection by creating a new bigger collection and then
copy over the contents from the old one. We grow by doubling the size
but the growth is kept between 20 and 1000000.
Finally we put <anObject> at the current write position."
| oldSize grownCollection |
oldSize _ collection size.
grownCollection _ collection class new: oldSize + ((oldSize max: 20) min: 1000000).
collection _ grownCollection replaceFrom: 1 to: oldSize with: collection startingAt: 1.
writeLimit _ collection size.
collection at: (position _ position + 1) put: anObject!
----- Method: WriteStream>>peekLast (in category 'character writing') -----
peekLast
"Return that item just put at the end of the stream"
^ position > 0
ifTrue: [collection at: position]
ifFalse: [nil]!
----- Method: WriteStream>>position: (in category 'positioning') -----
position: anInteger
"Refer to the comment in PositionableStream|position:."
readLimit _ readLimit max: position.
super position: anInteger!
----- Method: WriteStream>>reset (in category 'positioning') -----
reset
"Refer to the comment in PositionableStream|reset."
readLimit _ readLimit max: position.
position _ 0!
----- Method: WriteStream>>resetToStart (in category 'positioning') -----
resetToStart
readLimit _ position _ 0.!
----- Method: WriteStream>>setToEnd (in category 'positioning') -----
setToEnd
"Refer to the comment in PositionableStream|setToEnd."
readLimit _ readLimit max: position.
super setToEnd.!
----- Method: WriteStream>>size (in category 'accessing') -----
size
^readLimit _ readLimit max: position!
----- Method: WriteStream>>space (in category 'character writing') -----
space
"Append a space character to the receiver."
self nextPut: Character space!
----- Method: WriteStream>>space: (in category 'character writing') -----
space: anInteger
"Append anInteger space characters to the receiver."
anInteger timesRepeat: [self space]!
----- Method: WriteStream>>store: (in category 'printing') -----
store: anObject
"Have anObject print on the receiver for purposes of rereading."
anObject storeOn: self!
----- Method: WriteStream>>tab (in category 'character writing') -----
tab
"Append a tab character to the receiver."
self nextPut: Character tab!
----- Method: WriteStream>>tab: (in category 'character writing') -----
tab: anInteger
"Append anInteger tab characters to the receiver."
anInteger timesRepeat: [self tab]!
----- Method: WriteStream>>timeStamp (in category 'fileIn/Out') -----
timeStamp
"Append the current time to the receiver as a String."
self nextChunkPut: "double string quotes and !!s"
(String streamContents: [:s | SmalltalkImage current timeStamp: s]) printString.
self cr!
----- Method: WriteStream>>with: (in category 'private') -----
with: aCollection
super on: aCollection.
position _ readLimit _ writeLimit _ aCollection size!
----- Method: WriteStream>>withAttribute:do: (in category 'private') -----
withAttribute: att do: strmBlock
"No-op here is overriden in TextStream for font emphasis"
^ strmBlock value!
----- Method: WriteStream>>withAttributes:do: (in category 'private') -----
withAttributes: attributes do: strmBlock
"No-op here is overriden in TextStream for font emphasis"
^ strmBlock value!
----- Method: Stream class>>new (in category 'instance creation') -----
new
self error: 'Streams are created with on: and with:'!
----- Method: Stream>>atEnd (in category 'testing') -----
atEnd
"Answer whether the receiver can access any more objects."
self subclassResponsibility!
----- Method: Stream>>basicNext (in category 'accessing') -----
basicNext
^ self next.
!
----- Method: Stream>>basicNextPut: (in category 'accessing') -----
basicNextPut: anObject
^ self nextPut: anObject!
----- Method: Stream>>basicNextPutAll: (in category 'accessing') -----
basicNextPutAll: aCollection
^ self nextPutAll: aCollection.
!
----- Method: Stream>>binary (in category 'accessing') -----
binary!
----- Method: Stream>>close (in category 'file open/close') -----
close!
----- Method: Stream>>closed (in category 'testing') -----
closed
^ false!
----- Method: Stream>>contents (in category 'accessing') -----
contents
"Answer all of the contents of the receiver."
self subclassResponsibility!
----- Method: Stream>>dialect (in category 'alternate syntax') -----
dialect
^#ST80 "in case a regular stream is used to print parse nodes"!
----- Method: Stream>>do: (in category 'enumerating') -----
do: aBlock
"Evaluate aBlock for each of the objects accessible by receiver."
[self atEnd]
whileFalse: [aBlock value: self next]!
----- Method: Stream>>flush (in category 'accessing') -----
flush
"Do nothing by default"!
----- Method: Stream>>isStream (in category 'testing') -----
isStream
"Return true if the receiver responds to the stream protocol"
^true!
----- Method: Stream>>isTypeHTTP (in category 'testing') -----
isTypeHTTP
^false!
----- Method: Stream>>localName (in category 'accessing') -----
localName
^'a stream'!
----- Method: Stream>>next (in category 'accessing') -----
next
"Answer the next object accessible by the receiver."
self subclassResponsibility!
----- Method: Stream>>next: (in category 'accessing') -----
next: anInteger
"Answer the next anInteger number of objects accessible by the receiver."
| aCollection |
aCollection _ OrderedCollection new.
anInteger timesRepeat: [aCollection addLast: self next].
^aCollection!
----- Method: Stream>>next:put: (in category 'accessing') -----
next: anInteger put: anObject
"Make anObject be the next anInteger number of objects accessible by the
receiver. Answer anObject."
anInteger timesRepeat: [self nextPut: anObject].
^anObject!
----- Method: Stream>>nextMatchAll: (in category 'accessing') -----
nextMatchAll: aColl
"Answer true if next N objects are the ones in aColl,
else false. Advance stream of true, leave as was if false."
| save |
save _ self position.
aColl do: [:each |
(self next) = each ifFalse: [
self position: save.
^ false]
].
^ true!
----- Method: Stream>>nextMatchFor: (in category 'accessing') -----
nextMatchFor: anObject
"Gobble the next object and answer whether it is equal to the argument,
anObject."
^anObject = self next!
----- Method: Stream>>nextPut: (in category 'accessing') -----
nextPut: anObject
"Insert the argument, anObject, as the next object accessible by the
receiver. Answer anObject."
self subclassResponsibility!
----- Method: Stream>>nextPutAll: (in category 'accessing') -----
nextPutAll: aCollection
"Append the elements of aCollection to the sequence of objects accessible
by the receiver. Answer aCollection."
aCollection do: [:v | self nextPut: v].
^aCollection!
----- Method: Stream>>nextWordsPutAll: (in category 'testing') -----
nextWordsPutAll: aCollection
"Write the argument a word-like object in big endian format on the receiver.
May be used to write other than plain word-like objects (such as ColorArray)."
aCollection class isPointers | aCollection class isWords not
ifTrue: [^self error: aCollection class name,' is not word-like'].
1 to: aCollection basicSize do:[:i|
self nextNumber: 4 put: (aCollection basicAt: i).
].
^aCollection!
----- Method: Stream>>openReadOnly (in category 'accessing') -----
openReadOnly
^self!
----- Method: Stream>>print: (in category 'printing') -----
print: anObject
"Have anObject print itself on the receiver."
anObject printOn: self!
----- Method: Stream>>printHtml: (in category 'printing') -----
printHtml: anObject
anObject printHtmlOn: self!
----- Method: Stream>>printOn: (in category 'accessing') -----
printOn: stream
super printOn: stream.
stream space.
self contents printOn: stream.
!
----- Method: Stream>>readOnly (in category 'accessing') -----
readOnly
^self!
----- Method: Stream>>sleep (in category 'as yet unclassified') -----
sleep
"an FTP-based stream might close the connection here"!
----- Method: Stream>>upToEnd (in category 'accessing') -----
upToEnd
"answer the remaining elements in the string"
| elements |
elements _ OrderedCollection new.
[ self atEnd ] whileFalse: [
elements add: self next ].
^elements!
----- Method: Stream>>withStyleFor:do: (in category 'alternate syntax') -----
withStyleFor: elementType do: aBlock
^aBlock value "in case a regular stream is used to print parse nodes"
">>
(Compiler new compile: 'blah ^self' in: String notifying: nil ifFail: []) printString
<<"!
----- Method: Stream>>write: (in category 'filter streaming') -----
write:encodedObject
^encodedObject putOn:self.
!
Object subclass: #TextAttribute
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Text'!
!TextAttribute commentStamp: 'tk 7/22/2002 18:33' prior: 0!
Tells a piece of text to be a certain way.
Select text, press Command-6, choose a attribute. If selected text is of the form
Hi There<Smalltalk beep>
the part in angle brackets is saved for action, and the Hi There appears in the paragraph. If selection has no angle brackets, use the whole thing as both the text and the action.
TextDoIt -- eval as a Smalltalk expression (the part in angle brackets)
TextLink -- Show a method, class comment, class hierarchy, or class defintion.
<Point extent:>, <Point Comment>, <Point Hierarchy>, or <Point Defintion> are what you type.
TextURL -- Show the web page. <www.disney.com>
These attributes of text need to be stored on the disk in a regular file-out. It is done in this form: Hi There
in the text, and a Run containing dSmalltalk beep;;
Click here to see the extent:
in the text, and a Run containing method LPoint extent:;
See RunArray class scanFrom: where decoding is done.
!
TextAttribute subclass: #TextAction
instanceVariableNames: ''
classVariableNames: 'Purple'
poolDictionaries: ''
category: 'Collections-Text'!
TextAction subclass: #PluggableTextAttribute
instanceVariableNames: 'evalBlock'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Text'!
!PluggableTextAttribute commentStamp: '<historical>' prior: 0!
An attribute which evaluates an arbitrary block when it is selected.!
----- Method: PluggableTextAttribute class>>evalBlock: (in category 'instance creation') -----
evalBlock: aBlock
^super new evalBlock: aBlock!
----- Method: PluggableTextAttribute>>actOnClickFor: (in category 'clicking') -----
actOnClickFor: anObject
evalBlock ifNil: [ ^self ].
evalBlock numArgs = 0 ifTrue: [ evalBlock value. ^true ].
evalBlock numArgs = 1 ifTrue: [ evalBlock value: anObject. ^true ].
self error: 'evalBlock should have 0 or 1 arguments'!
----- Method: PluggableTextAttribute>>evalBlock: (in category 'initialization') -----
evalBlock: aBlock
evalBlock := aBlock!
----- Method: TextAction class>>initialize (in category 'as yet unclassified') -----
initialize "TextAction initialize"
Purple _ Color r: 0.4 g: 0 b: 1.0!
----- Method: TextAction>>analyze: (in category 'as yet unclassified') -----
analyze: aString
"Analyze the selected text to find both the parameter to store and the text to emphesize (may be different from original selection). Does not return self!!. May be of the form:
3+4
<3+4>
Click Here<3+4>
<3+4>Click Here
"
"Obtain the showing text and the instructions"
| b1 b2 trim param show |
b1 _ aString indexOf: $<.
b2 _ aString indexOf: $>.
(b1 < b2) & (b1 > 0) ifFalse: ["only one part"
param _ self validate: aString.
^ Array with: param with: (param size = 0 ifTrue: [nil] ifFalse: [param])].
"Two parts"
trim _ aString withBlanksTrimmed.
(trim at: 1) == $<
ifTrue: [(trim last) == $>
ifTrue: ["only instructions"
param _ self validate: (aString copyFrom: b1+1 to: b2-1).
show _ param size = 0 ifTrue: [nil] ifFalse: [param]]
ifFalse: ["at the front"
param _ self validate: (aString copyFrom: b1+1 to: b2-1).
show _ param size = 0 ifTrue: [nil]
ifFalse: [aString copyFrom: b2+1 to: aString size]]]
ifFalse: [(trim last) == $>
ifTrue: ["at the end"
param _ self validate: (aString copyFrom: b1+1 to: b2-1).
show _ param size = 0 ifTrue: [nil]
ifFalse: [aString copyFrom: 1 to: b1-1]]
ifFalse: ["Illegal -- <> has text on both sides"
show _ nil]].
^ Array with: param with: show
!
----- Method: TextAction>>couldDeriveFromPrettyPrinting (in category 'as yet unclassified') -----
couldDeriveFromPrettyPrinting
^ false!
----- Method: TextAction>>dominatedByCmd0 (in category 'as yet unclassified') -----
dominatedByCmd0
"Cmd-0 should turn off active text"
^ true!
----- Method: TextAction>>emphasizeScanner: (in category 'as yet unclassified') -----
emphasizeScanner: scanner
"Set the emphasis for text display"
scanner textColor: Purple!
----- Method: TextAction>>info (in category 'as yet unclassified') -----
info
^ 'no hidden info'!
----- Method: TextAction>>mayActOnClick (in category 'as yet unclassified') -----
mayActOnClick
^ true!
----- Method: TextAction>>validate: (in category 'as yet unclassified') -----
validate: aString
"any format is OK with me"
^ aString!
TextAction subclass: #TextDoIt
instanceVariableNames: 'evalString'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Text'!
----- Method: TextDoIt class>>evalString: (in category 'as yet unclassified') -----
evalString: str
^ self new evalString: str!
----- Method: TextDoIt class>>scanFrom: (in category 'as yet unclassified') -----
scanFrom: strm
"read a doit in the funny format used by Text styles on files. d10 factorial;; end with two semicolons"
| pos end doit |
pos _ strm position.
[strm skipTo: $;. strm peek == $;] whileFalse.
end _ strm position - 1.
strm position: pos.
doit _ strm next: end-pos.
strm skip: 2. ";;"
^ self evalString: doit!
----- Method: TextDoIt>>actOnClickFor: (in category 'as yet unclassified') -----
actOnClickFor: anObject
"Note: evalString gets evaluated IN THE CONTEXT OF anObject
-- meaning that self and all instVars are accessible"
Compiler evaluate: evalString for: anObject logged: false.
^ true !
----- Method: TextDoIt>>analyze: (in category 'as yet unclassified') -----
analyze: aString
| list |
list _ super analyze: aString.
evalString _ list at: 1.
^ list at: 2!
----- Method: TextDoIt>>evalString: (in category 'as yet unclassified') -----
evalString: str
evalString _ str !
----- Method: TextDoIt>>info (in category 'as yet unclassified') -----
info
^ evalString!
----- Method: TextDoIt>>writeScanOn: (in category 'as yet unclassified') -----
writeScanOn: strm
strm nextPut: $d; nextPutAll: evalString; nextPutAll: ';;'!
TextDoIt subclass: #TextPrintIt
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Text'!
----- Method: TextPrintIt>>actOnClickFor:in:at:editor: (in category 'as yet unclassified') -----
actOnClickFor: anObject in: aParagraph at: clickPoint editor: editor
"Note: evalString gets evaluated IN THE CONTEXT OF anObject
-- meaning that self and all instVars are accessible"
| result range index |
result _ Compiler evaluate: evalString for: anObject logged: false.
result _ ' ', result printString,' '.
"figure out where the attribute ends in aParagraph"
index _ (aParagraph characterBlockAtPoint: clickPoint) stringIndex.
range _ aParagraph text rangeOf: self startingAt: index.
editor selectFrom: range last+1 to: range last.
editor zapSelectionWith: result.
editor selectFrom: range last to: range last + result size.
^ true !
----- Method: TextPrintIt>>writeScanOn: (in category 'as yet unclassified') -----
writeScanOn: strm
strm nextPut: $P; nextPutAll: evalString; nextPutAll: ';;'!
TextAction subclass: #TextLink
instanceVariableNames: 'classAndMethod'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Text'!
----- Method: TextLink class>>scanFrom: (in category 'as yet unclassified') -----
scanFrom: strm
"read a link in the funny format used by Text styles on files. LPoint +;LPoint Comment;"
^ self new classAndMethod: (strm upTo: $;)!
----- Method: TextLink>>actOnClickFor: (in category 'as yet unclassified') -----
actOnClickFor: aMessageSet
"Add to the end of the list. 'aClass selector', 'aClass Comment', 'aClass Definition', 'aClass Hierarchy' are the formats allowed."
aMessageSet addItem: classAndMethod.
^ true!
----- Method: TextLink>>analyze: (in category 'as yet unclassified') -----
analyze: aString
| list |
list _ super analyze: aString.
classAndMethod _ list at: 1.
^ list at: 2!
----- Method: TextLink>>analyze:with: (in category 'as yet unclassified') -----
analyze: aString with: nonMethod
"Initalize this attribute holder with a piece text the user typed into a paragraph. Returns the text to emphesize (may be different from selection) Does not return self!!. nonMethod is what to show when clicked, i.e. the last part of specifier (Comment, Definition, or Hierarchy). May be of the form:
Point
<Point>
Click Here<Point>
<Point>Click Here
"
"Obtain the showing text and the instructions"
| b1 b2 trim |
b1 _ aString indexOf: $<.
b2 _ aString indexOf: $>.
(b1 < b2) & (b1 > 0) ifFalse: ["only one part"
classAndMethod _ self validate: aString, ' ', nonMethod.
^ classAndMethod ifNotNil: [aString]].
"Two parts"
trim _ aString withBlanksTrimmed.
(trim at: 1) == $<
ifTrue: [(trim last) == $>
ifTrue: ["only instructions"
classAndMethod _ self validate: (aString copyFrom: b1+1 to: b2-1), ' ', nonMethod.
^ classAndMethod ifNotNil: [classAndMethod]]
ifFalse: ["at the front"
classAndMethod _ self validate: (aString copyFrom: b1+1 to: b2-1), ' ', nonMethod.
^ classAndMethod ifNotNil: [aString copyFrom: b2+1 to: aString size]]]
ifFalse: [(trim last) == $>
ifTrue: ["at the end"
classAndMethod _ self validate: (aString copyFrom: b1+1 to: b2-1), ' ', nonMethod.
^ classAndMethod ifNotNil: [aString copyFrom: 1 to: b1-1]]
ifFalse: ["Illegal -- <> has text on both sides"
^ nil]]
!
----- Method: TextLink>>classAndMethod: (in category 'as yet unclassified') -----
classAndMethod: aString
classAndMethod _ aString!
----- Method: TextLink>>info (in category 'as yet unclassified') -----
info
^ classAndMethod!
----- Method: TextLink>>validate: (in category 'as yet unclassified') -----
validate: specString
"Can this string be decoded to be Class space Method (or Comment, Definition, Hierarchy)? If so, return it in valid format, else nil"
| list first mid last |
list _ specString findTokens: ' .|'.
last _ list last.
last first isUppercase ifTrue: [
(#('Comment' 'Definition' 'Hierarchy') includes: last) ifFalse: [^ nil].
"Check for 'Rectangle Comment Comment' and remove last one"
(list at: list size - 1) = last ifTrue: [list _ list allButLast]].
list size > 3 ifTrue: [^ nil].
list size < 2 ifTrue: [^ nil].
Symbol hasInterned: list first ifTrue: [:sym | first _ sym].
first ifNil: [^ nil].
Smalltalk at: first ifAbsent: [^ nil].
mid _ list size = 3
ifTrue: [(list at: 2) = 'class' ifTrue: ['class '] ifFalse: [^ nil]]
ifFalse: [''].
"OK if method name is not interned -- may not be defined yet"
^ first, ' ', mid, last!
----- Method: TextLink>>writeScanOn: (in category 'as yet unclassified') -----
writeScanOn: strm
strm nextPut: $L; nextPutAll: classAndMethod; nextPut: $;!
TextAction subclass: #TextURL
instanceVariableNames: 'url'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Text'!
TextURL subclass: #TextSqkPageLink
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Text'!
!TextSqkPageLink commentStamp: '<historical>' prior: 0!
I represent a link to either a SqueakPage in a BookMorph, or a regular url. See TextMorphEditor changeEmphasis:.
!
----- Method: TextSqkPageLink>>actOnClickFor: (in category 'as yet unclassified') -----
actOnClickFor: textMorph
"I represent a link to either a SqueakPage in a BookMorph, or a regular url"
| book |
((url endsWith: '.bo') or: [url endsWith: '.sp']) ifFalse: [
^ super actOnClickFor: textMorph].
book _ textMorph ownerThatIsA: BookMorph.
book ifNotNil: [book goToPageUrl: url].
"later handle case of page being in another book, not this one"
^ true!
----- Method: TextSqkPageLink>>writeScanOn: (in category 'as yet unclassified') -----
writeScanOn: strm
strm nextPut: $q; nextPutAll: url; nextPut: $;!
TextURL subclass: #TextSqkProjectLink
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Text'!
----- Method: TextSqkProjectLink>>actOnClickFor: (in category 'as yet unclassified') -----
actOnClickFor: textMorph
Project enterIfThereOrFind: url.
^ true!
----- Method: TextSqkProjectLink>>analyze: (in category 'as yet unclassified') -----
analyze: aString
^url _ aString!
----- Method: TextSqkProjectLink>>writeScanOn: (in category 'as yet unclassified') -----
writeScanOn: strm
strm nextPut: $p; nextPutAll: url; nextPut: $;!
----- Method: TextURL class>>scanFrom: (in category 'as yet unclassified') -----
scanFrom: strm
"read a link in the funny format used by Text styles on files. Rhttp://www.disney.com;"
^ self new url: (strm upTo: $;)!
----- Method: TextURL>>actOnClickFor: (in category 'as yet unclassified') -----
actOnClickFor: anObject
"Do what you can with this URL. Later a web browser."
| response m |
(url beginsWith: 'sqPr://') ifTrue: [
ProjectLoading thumbnailFromUrl: (url copyFrom: 8 to: url size).
^self "should not get here, but what the heck"
].
"if it's a web browser, tell it to jump"
anObject isWebBrowser
ifTrue: [anObject jumpToUrl: url. ^ true]
ifFalse: [((anObject respondsTo: #model) and: [anObject model isWebBrowser])
ifTrue: [anObject model jumpToUrl: url. ^ true]].
"if it's a morph, see if it is contained in a web browser"
(anObject isKindOf: Morph) ifTrue: [
m _ anObject.
[ m ~= nil ] whileTrue: [
(m isWebBrowser) ifTrue: [
m jumpToUrl: url.
^true ].
(m hasProperty: #webBrowserView) ifTrue: [
m model jumpToUrl: url.
^true ].
m _ m owner. ]
].
"no browser in sight. ask if we should start a new browser"
((self confirm: 'open a browser to view this URL?' translated) and: [WebBrowser default notNil]) ifTrue: [
WebBrowser default openOnUrl: url.
^ true ].
"couldn't display in a browser. Offer to put up just the source"
response _ (PopUpMenu labels: 'View web page as source
Cancel' translated)
startUpWithCaption: 'Couldn''t find a web browser. View
page as source?' translated.
response = 1 ifTrue: [HTTPSocket httpShowPage: url].
^ true!
----- Method: TextURL>>analyze: (in category 'as yet unclassified') -----
analyze: aString
| list |
list _ super analyze: aString.
url _ list at: 1.
^ list at: 2!
----- Method: TextURL>>info (in category 'as yet unclassified') -----
info
^ url!
----- Method: TextURL>>url: (in category 'as yet unclassified') -----
url: aString
url _ aString!
----- Method: TextURL>>writeScanOn: (in category 'as yet unclassified') -----
writeScanOn: strm
strm nextPut: $R; nextPutAll: url; nextPut: $;!
TextAttribute subclass: #TextAlignment
instanceVariableNames: 'alignment'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Text'!
----- Method: TextAlignment class>>alignmentSymbol: (in category 'as yet unclassified') -----
alignmentSymbol: alignmentCode
^#(leftFlush rightFlush centered justified) at: (alignmentCode + 1)!
----- Method: TextAlignment class>>centered (in category 'instance creation') -----
centered
^self new alignment: 2!
----- Method: TextAlignment class>>justified (in category 'instance creation') -----
justified
^self new alignment: 3!
----- Method: TextAlignment class>>leftFlush (in category 'instance creation') -----
leftFlush
^self new alignment: 0!
----- Method: TextAlignment class>>rightFlush (in category 'instance creation') -----
rightFlush
^self new alignment: 1!
----- Method: TextAlignment>>= (in category 'as yet unclassified') -----
= other
^ (other class == self class)
and: [other alignment = alignment]!
----- Method: TextAlignment>>alignment (in category 'as yet unclassified') -----
alignment
^alignment!
----- Method: TextAlignment>>alignment: (in category 'as yet unclassified') -----
alignment: aNumber
alignment _ aNumber.!
----- Method: TextAlignment>>asPangoValueFrom:to: (in category 'pango') -----
asPangoValueFrom: start to: end
^ Array with: #A with: start with: end with: alignment
!
----- Method: TextAlignment>>dominates: (in category 'as yet unclassified') -----
dominates: other
"There can be only one..."
^self class == other class!
----- Method: TextAlignment>>emphasizeScanner: (in category 'as yet unclassified') -----
emphasizeScanner: scanner
"Set the emphasist for text scanning"
scanner setAlignment: alignment.!
----- Method: TextAlignment>>hash (in category 'as yet unclassified') -----
hash
"#hash is re-implemented because #= is re-implemented"
^ alignment hash!
----- Method: TextAlignment>>writeScanOn: (in category 'as yet unclassified') -----
writeScanOn: strm
strm nextPut: $a.
alignment printOn: strm.!
----- Method: TextAttribute>>actOnClickFor: (in category 'as yet unclassified') -----
actOnClickFor: model
"Subclasses may override to provide, eg, hot-spot actions"
^ false!
----- Method: TextAttribute>>actOnClickFor:in: (in category 'as yet unclassified') -----
actOnClickFor: model in: aParagraph
^self actOnClickFor: model!
----- Method: TextAttribute>>actOnClickFor:in:at: (in category 'as yet unclassified') -----
actOnClickFor: model in: aParagraph at: clickPoint
^self actOnClickFor: model in: aParagraph!
----- Method: TextAttribute>>actOnClickFor:in:at:editor: (in category 'as yet unclassified') -----
actOnClickFor: model in: aParagraph at: clickPoint editor: editor
^self actOnClickFor: model in: aParagraph at: clickPoint!
----- Method: TextAttribute>>anchoredMorph (in category 'as yet unclassified') -----
anchoredMorph
"If one hides here, return it"
^nil!
----- Method: TextAttribute>>couldDeriveFromPrettyPrinting (in category 'as yet unclassified') -----
couldDeriveFromPrettyPrinting
"Answer whether the receiver is a kind of attribute that could have been generated by doing polychrome pretty-printing of a method without functional text attributes."
^ true!
----- Method: TextAttribute>>dominatedByCmd0 (in category 'as yet unclassified') -----
dominatedByCmd0
"Subclasses may override if cmd-0 should turn them off"
^ false!
----- Method: TextAttribute>>dominates: (in category 'as yet unclassified') -----
dominates: another
"Subclasses may override condense multiple attributes"
^ false!
----- Method: TextAttribute>>emphasisCode (in category 'as yet unclassified') -----
emphasisCode
"Subclasses may override to add bold, italic, etc"
^ 0!
----- Method: TextAttribute>>emphasizeScanner: (in category 'as yet unclassified') -----
emphasizeScanner: scanner
"Subclasses may override to set, eg, font, color, etc"!
----- Method: TextAttribute>>forFontInStyle:do: (in category 'as yet unclassified') -----
forFontInStyle: aTextStyle do: aBlock
"No action is the default. Overridden by font specs"!
----- Method: TextAttribute>>isKern (in category 'testing') -----
isKern
^false!
----- Method: TextAttribute>>mayActOnClick (in category 'as yet unclassified') -----
mayActOnClick
"Subclasses may override to provide, eg, hot-spot actions"
^ false!
----- Method: TextAttribute>>mayBeExtended (in category 'as yet unclassified') -----
mayBeExtended
"A quality that may be overridden by subclasses, such as TextAnchors, that really only apply to a single character"
^ true!
----- Method: TextAttribute>>oldEmphasisCode: (in category 'as yet unclassified') -----
oldEmphasisCode: default
"Allows running thorugh possibly multiple attributes
and getting the emphasis out of any that has an emphasis (font number)"
^ default!
----- Method: TextAttribute>>reset (in category 'as yet unclassified') -----
reset
"Allow subclasses to prepare themselves for merging attributes"!
----- Method: TextAttribute>>set (in category 'as yet unclassified') -----
set
"Respond true to include this attribute (as opposed to, eg, a bold
emphasizer that is clearing the property"
^ true!
TextAttribute subclass: #TextColor
instanceVariableNames: 'color'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Text'!
!TextColor commentStamp: '<historical>' prior: 0!
A TextColor encodes a text color change applicable over a given range of text.!
----- Method: TextColor class>>black (in category 'constants') -----
black
^ self new color: Color black!
----- Method: TextColor class>>blue (in category 'constants') -----
blue
^ self new color: Color blue!
----- Method: TextColor class>>color: (in category 'instance creation') -----
color: aColor
^ self new color: aColor!
----- Method: TextColor class>>cyan (in category 'constants') -----
cyan
^ self new color: Color cyan!
----- Method: TextColor class>>gray (in category 'constants') -----
gray
^ self new color: Color gray!
----- Method: TextColor class>>green (in category 'constants') -----
green
^ self new color: Color green!
----- Method: TextColor class>>magenta (in category 'constants') -----
magenta
^ self new color: Color magenta!
----- Method: TextColor class>>red (in category 'constants') -----
red
^ self new color: Color red!
----- Method: TextColor class>>scanFrom: (in category 'instance creation') -----
scanFrom: strm
"read a color in the funny format used by Text styles on files. c125000255 or cblue;"
| r g b |
strm peek isDigit
ifTrue:
[r _ (strm next: 3) asNumber.
g _ (strm next: 3) asNumber.
b _ (strm next: 3) asNumber.
^ self color: (Color r: r g: g b: b range: 255)].
"A name of a color"
^ self color: (Color perform: (strm upTo: $;) asSymbol)!
----- Method: TextColor class>>white (in category 'constants') -----
white
^ self new color: Color white!
----- Method: TextColor class>>yellow (in category 'constants') -----
yellow
^ self new color: Color yellow!
----- Method: TextColor>>= (in category 'comparing') -----
= other
^ (other class == self class)
and: [other color = color]!
----- Method: TextColor>>asPangoValueFrom:to: (in category 'pango') -----
asPangoValueFrom: start to: end
^ Array with: #C with: start with: end with: color pixelValue32.
!
----- Method: TextColor>>color (in category 'accessing') -----
color
^ color!
----- Method: TextColor>>color: (in category 'accessing') -----
color: aColor
color _ aColor!
----- Method: TextColor>>dominates: (in category 'scanning') -----
dominates: other
^ other class == self class!
----- Method: TextColor>>emphasizeScanner: (in category 'scanning') -----
emphasizeScanner: scanner
"Set the emphasis for text display"
scanner textColor: color!
----- Method: TextColor>>hash (in category 'comparing') -----
hash
^ color hash!
----- Method: TextColor>>printOn: (in category 'printing') -----
printOn: aStream
super printOn: aStream.
aStream nextPutAll: ' code: '; print: color!
----- Method: TextColor>>writeScanOn: (in category 'scanning') -----
writeScanOn: strm
"Two formats. c125000255 or cblue;"
| nn str |
strm nextPut: $c.
(nn _ color name) ifNotNil: [
(self class respondsTo: nn) ifTrue: [
^ strm nextPutAll: nn; nextPut: $;]].
(Array with: color red with: color green with: color blue) do: [:float |
str _ '000', (float * 255) asInteger printString.
strm nextPutAll: (str copyFrom: str size-2 to: str size)]!
TextAttribute subclass: #TextEmphasis
instanceVariableNames: 'emphasisCode setMode'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Text'!
!TextEmphasis commentStamp: '<historical>' prior: 0!
A TextEmphasis, encodes a characteristic applicable to all fonts. The encoding is as follows:
1 bold
2 itallic
4 underlined
8 narrow
16 struck out!
----- Method: TextEmphasis class>>bold (in category 'as yet unclassified') -----
bold
^ self new emphasisCode: 1!
----- Method: TextEmphasis class>>italic (in category 'as yet unclassified') -----
italic
^ self new emphasisCode: 2!
----- Method: TextEmphasis class>>narrow (in category 'as yet unclassified') -----
narrow
^ TextKern kern: -1!
----- Method: TextEmphasis class>>normal (in category 'as yet unclassified') -----
normal
^ self new emphasisCode: 0!
----- Method: TextEmphasis class>>struckOut (in category 'as yet unclassified') -----
struckOut
^ self new emphasisCode: 16!
----- Method: TextEmphasis class>>underlined (in category 'as yet unclassified') -----
underlined
^ self new emphasisCode: 4!
----- Method: TextEmphasis>>= (in category 'as yet unclassified') -----
= other
^ (other class == self class)
and: [other emphasisCode = emphasisCode]!
----- Method: TextEmphasis>>dominatedByCmd0 (in category 'as yet unclassified') -----
dominatedByCmd0
"Cmd-0 should turn off emphasis"
^ true!
----- Method: TextEmphasis>>dominates: (in category 'as yet unclassified') -----
dominates: other
(emphasisCode = 0 and: [other dominatedByCmd0]) ifTrue: [^ true].
^ (other class == self class)
and: [emphasisCode = other emphasisCode]!
----- Method: TextEmphasis>>emphasisCode (in category 'as yet unclassified') -----
emphasisCode
^ emphasisCode!
----- Method: TextEmphasis>>emphasisCode: (in category 'as yet unclassified') -----
emphasisCode: int
emphasisCode _ int.
setMode _ true!
----- Method: TextEmphasis>>emphasizeScanner: (in category 'as yet unclassified') -----
emphasizeScanner: scanner
"Set the emphasist for text scanning"
scanner addEmphasis: emphasisCode!
----- Method: TextEmphasis>>hash (in category 'as yet unclassified') -----
hash
"#hash is re-implemented because #= is re-implemented"
^emphasisCode hash
!
----- Method: TextEmphasis>>printOn: (in category 'as yet unclassified') -----
printOn: strm
super printOn: strm.
strm nextPutAll: ' code: '; print: emphasisCode!
----- Method: TextEmphasis>>set (in category 'as yet unclassified') -----
set
^ setMode and: [emphasisCode ~= 0]!
----- Method: TextEmphasis>>turnOff (in category 'as yet unclassified') -----
turnOff
setMode _ false!
----- Method: TextEmphasis>>writeScanOn: (in category 'as yet unclassified') -----
writeScanOn: strm
emphasisCode = 1 ifTrue: [strm nextPut: $b].
emphasisCode = 2 ifTrue: [strm nextPut: $i].
emphasisCode = 0 ifTrue: [strm nextPut: $n].
emphasisCode = 16 ifTrue: [strm nextPut: $=].
emphasisCode = 4 ifTrue: [strm nextPut: $u].!
TextAttribute subclass: #TextFontChange
instanceVariableNames: 'fontNumber'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Text'!
!TextFontChange commentStamp: '<historical>' prior: 0!
A TextFontChange encodes a font change applicable over a given range of text. The font number is interpreted relative to the textStyle governing display of this text.!
----- Method: TextFontChange class>>defaultFontChange (in category 'as yet unclassified') -----
defaultFontChange
"Answer a TextFontChange that represents the default font"
^ self new fontNumber: TextStyle default defaultFontIndex!
----- Method: TextFontChange class>>font1 (in category 'as yet unclassified') -----
font1
^ self new fontNumber: 1!
----- Method: TextFontChange class>>font2 (in category 'as yet unclassified') -----
font2
^ self new fontNumber: 2!
----- Method: TextFontChange class>>font3 (in category 'as yet unclassified') -----
font3
^ self new fontNumber: 3!
----- Method: TextFontChange class>>font4 (in category 'as yet unclassified') -----
font4
^ self new fontNumber: 4!
----- Method: TextFontChange class>>fontNumber: (in category 'as yet unclassified') -----
fontNumber: n
^ self new fontNumber: n!
----- Method: TextFontChange>>= (in category 'as yet unclassified') -----
= other
^ (other class == self class)
and: [other fontNumber = fontNumber]!
----- Method: TextFontChange>>dominates: (in category 'as yet unclassified') -----
dominates: other
^ other isKindOf: TextFontChange!
----- Method: TextFontChange>>emphasizeScanner: (in category 'as yet unclassified') -----
emphasizeScanner: scanner
"Set the font for text display"
scanner setFont: fontNumber!
----- Method: TextFontChange>>fontNumber (in category 'as yet unclassified') -----
fontNumber
^ fontNumber!
----- Method: TextFontChange>>fontNumber: (in category 'as yet unclassified') -----
fontNumber: int
fontNumber _ int!
----- Method: TextFontChange>>forFontInStyle:do: (in category 'as yet unclassified') -----
forFontInStyle: aTextStyle do: aBlock
aBlock value: (aTextStyle fontAt: fontNumber)!
----- Method: TextFontChange>>hash (in category 'as yet unclassified') -----
hash
"#hash is re-implemented because #= is re-implemented"
^fontNumber hash!
----- Method: TextFontChange>>printOn: (in category 'as yet unclassified') -----
printOn: strm
super printOn: strm.
strm nextPutAll: ' font: '; print: fontNumber!
----- Method: TextFontChange>>writeScanOn: (in category 'as yet unclassified') -----
writeScanOn: strm
strm nextPut: $f.
fontNumber printOn: strm.!
TextFontChange subclass: #TextFontReference
instanceVariableNames: 'font'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Text'!
!TextFontReference commentStamp: '<historical>' prior: 0!
A TextFontReference encodes a font change applicable over a given range of text. The font reference is absolute: unlike a TextFontChange, it is independent of the textStyle governing display of this text.!
----- Method: TextFontReference class>>toFont: (in category 'as yet unclassified') -----
toFont: aFont
^ self new toFont: aFont!
----- Method: TextFontReference>>= (in category 'comparing') -----
= other
^ (other class == self class)
and: [other font = font]!
----- Method: TextFontReference>>couldDeriveFromPrettyPrinting (in category 'as yet unclassified') -----
couldDeriveFromPrettyPrinting
^ false!
----- Method: TextFontReference>>emphasizeScanner: (in category 'as yet unclassified') -----
emphasizeScanner: scanner
"Set the actual font for text display"
scanner setActualFont: font!
----- Method: TextFontReference>>font (in category 'as yet unclassified') -----
font
^ font!
----- Method: TextFontReference>>forFontInStyle:do: (in category 'as yet unclassified') -----
forFontInStyle: aTextStyle do: aBlock
aBlock value: font!
----- Method: TextFontReference>>hash (in category 'comparing') -----
hash
"#hash is re-implemented because #= is re-implemented"
^font hash!
----- Method: TextFontReference>>printOn: (in category 'comparing') -----
printOn: aStream
aStream nextPutAll: 'a TextFontReference(';
print: font;
nextPut: $)!
----- Method: TextFontReference>>toFont: (in category 'as yet unclassified') -----
toFont: aFont
font _ aFont!
----- Method: TextFontReference>>writeScanOn: (in category 'as yet unclassified') -----
writeScanOn: strm
strm nextPut: $F.
strm nextPutAll: font familyName; nextPut: $#.
font height printOn: strm.!
TextAttribute subclass: #TextIndent
instanceVariableNames: 'amount'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Text'!
!TextIndent commentStamp: '<historical>' prior: 0!
create a hanging indent. !
----- Method: TextIndent class>>amount: (in category 'instance creation') -----
amount: amount
"create a TextIndent which will indent by the given amount. Currently this is a number of tabs, but may change in the futur"
^super new amount: amount!
----- Method: TextIndent class>>example (in category 'example') -----
example
"TextIndent example"
| text pg |
"create an example text with some indentation"
text _ 'abcdao euoaeuo aeuo aeuoaeu o aeuoeauefgh bcd efghi' asText.
text addAttribute: (TextColor red) from: 3 to: 8.
text addAttribute: (TextIndent amount: 1) from: 1 to: 2.
text addAttribute: (TextIndent amount: 2) from: 20 to: 35.
"stick it in a paragraph and display it"
pg _ text asParagraph.
pg compositionRectangle: (0 at 0 extent: 100 at 200).
pg textStyle alignment: 2.
pg displayAt: 0 at 0.
!
----- Method: TextIndent class>>tabs: (in category 'instance creation') -----
tabs: numTabs
"create an indentation by the given number of tabs"
^self amount: numTabs!
----- Method: TextIndent>>amount (in category 'access') -----
amount
"number of tab spaces to indent by"
^amount!
----- Method: TextIndent>>amount: (in category 'access') -----
amount: anInteger
"change the number of tabs to indent by"
amount _ anInteger!
----- Method: TextIndent>>dominates: (in category 'condensing') -----
dominates: anAttribute
^(self class == anAttribute class)!
----- Method: TextIndent>>emphasizeScanner: (in category 'setting indentation') -----
emphasizeScanner: scanner
scanner indentationLevel: amount!
----- Method: TextIndent>>printOn: (in category 'printing') -----
printOn: aStream
super printOn: aStream.
aStream nextPutAll: ' amount: '.
amount printOn: aStream!
TextAttribute subclass: #TextKern
instanceVariableNames: 'kern active'
classVariableNames: ''
poolDictionaries: ''
category: 'Collections-Text'!
!TextKern commentStamp: '<historical>' prior: 0!
A TextKern encodes a kerning change applicable over a given range of text. Positive values of kern spread letters out, negative kern will cause them to overlap more. Note that kerns other than 0 will display somewhat slower, as kerning is not yet supported in the text scanning primitive. !
----- Method: TextKern class>>kern: (in category 'as yet unclassified') -----
kern: kernValue
^ self new kern: kernValue!
----- Method: TextKern>>= (in category 'as yet unclassified') -----
= other
^ (other class == self class)
and: [other kern = kern]!
----- Method: TextKern>>couldDeriveFromPrettyPrinting (in category 'as yet unclassified') -----
couldDeriveFromPrettyPrinting
^ false!
----- Method: TextKern>>dominatedByCmd0 (in category 'as yet unclassified') -----
dominatedByCmd0
"Cmd-0 should turn off kerning"
^ true!
----- Method: TextKern>>dominates: (in category 'as yet unclassified') -----
dominates: other
"NOTE: The use of active in this code is specific to its use in the method
Text class addAttribute: att toArray: others"
(active and: [other class == self class and: [other kern + kern = 0]])
ifTrue: [active _ false. ^ true]. "can only dominate once"
^ false!
----- Method: TextKern>>emphasizeScanner: (in category 'as yet unclassified') -----
emphasizeScanner: scanner
"Augment (or diminish) the kerning offset for text display"
scanner addKern: kern!
----- Method: TextKern>>hash (in category 'as yet unclassified') -----
hash
"#hash is re-implemented because #= is re-implemented"
^kern hash!
----- Method: TextKern>>isKern (in category 'testing') -----
isKern
^true!
----- Method: TextKern>>kern (in category 'as yet unclassified') -----
kern
^ kern!
----- Method: TextKern>>kern: (in category 'as yet unclassified') -----
kern: kernValue
kern _ kernValue.
self reset.!
----- Method: TextKern>>reset (in category 'as yet unclassified') -----
reset
active _ true!
----- Method: TextKern>>set (in category 'as yet unclassified') -----
set
^ active!
----- Method: TextKern>>writeScanOn: (in category 'as yet unclassified') -----
writeScanOn: strm
kern > 0 ifTrue: [
1 to: kern do: [:kk | strm nextPut: $+]].
kern < 0 ifTrue: [
1 to: 0-kern do: [:kk | strm nextPut: $-]].!
Object subclass: #LimitingLineStreamWrapper
instanceVariableNames: 'stream line limitingBlock position'
classVariableNames: ''
poolDictionaries: 'TextConstants'
category: 'Collections-Streams'!
!LimitingLineStreamWrapper commentStamp: '<historical>' prior: 0!
I'm a wrapper for a stream optimized for line-by-line access using #nextLine. My instances can be nested.
I read one line ahead. Reading terminates when the stream ends, or if the limitingBlock evaluated with the line answers true. To skip the delimiting line for further reading use #skipThisLine.
Character-based reading (#next) is permitted, too. Send #updatePosition when switching from line-based reading.
See examples at the class side.
--bf 2/19/1999 12:52!
----- Method: LimitingLineStreamWrapper class>>example1 (in category 'examples') -----
example1
"LimitingLineStreamWrapper example1"
"Separate chunks of text delimited by a special string"
| inStream msgStream messages |
inStream _ self exampleStream.
msgStream _ LimitingLineStreamWrapper on: inStream delimiter: 'From '.
messages _ OrderedCollection new.
[inStream atEnd] whileFalse: [
msgStream skipThisLine.
messages add: msgStream upToEnd].
^messages
!
----- Method: LimitingLineStreamWrapper class>>example2 (in category 'examples') -----
example2
"LimitingLineStreamWrapper example2"
"Demo nesting wrappers - get header lines from some messages"
| inStream msgStream headers headerStream |
inStream _ self exampleStream.
msgStream _ LimitingLineStreamWrapper on: inStream delimiter: 'From '.
headers _ OrderedCollection new.
[inStream atEnd] whileFalse: [
msgStream skipThisLine. "Skip From"
headerStream _ LimitingLineStreamWrapper on: msgStream delimiter: ''.
headers add: headerStream linesUpToEnd.
[msgStream nextLine isNil] whileFalse. "Skip Body"
].
^headers
!
----- Method: LimitingLineStreamWrapper class>>exampleStream (in category 'examples') -----
exampleStream
^ReadStream on:
'From me at somewhere
From: me
To: you
Subject: Test
Test
>From you at elsewhere
From: you
To: me
Subject: Re: test
okay
'!
----- Method: LimitingLineStreamWrapper class>>on:delimiter: (in category 'instance creation') -----
on: aStream delimiter: aString
^self new setStream: aStream delimiter: aString
!
----- Method: LimitingLineStreamWrapper>>atEnd (in category 'testing') -----
atEnd
^line isNil or: [limitingBlock value: line]!
----- Method: LimitingLineStreamWrapper>>close (in category 'stream protocol') -----
close
^stream close!
----- Method: LimitingLineStreamWrapper>>delimiter: (in category 'accessing') -----
delimiter: aString
"Set limitBlock to check for a delimiting string. Be unlimiting if nil"
self limitingBlock: (aString caseOf: {
[nil] -> [[:aLine | false]].
[''] -> [[:aLine | aLine size = 0]]
} otherwise: [[:aLine | aLine beginsWith: aString]])
!
----- Method: LimitingLineStreamWrapper>>lastLineRead (in category 'accessing') -----
lastLineRead
"Return line last read. At stream end, this is the boundary line or nil"
^ line!
----- Method: LimitingLineStreamWrapper>>limitingBlock: (in category 'accessing') -----
limitingBlock: aBlock
"The limitingBlock is evaluated with a line to check if this line terminates the stream"
limitingBlock _ aBlock fixTemps.
self updatePosition!
----- Method: LimitingLineStreamWrapper>>linesUpToEnd (in category 'accessing') -----
linesUpToEnd
| elements ln |
elements _ OrderedCollection new.
[(ln _ self nextLine) isNil] whileFalse: [
elements add: ln].
^elements!
----- Method: LimitingLineStreamWrapper>>next (in category 'accessing') -----
next
"Provide character-based access"
position isNil ifTrue: [^nil].
position < line size ifTrue: [^line at: (position _ position + 1)].
line _ stream nextLine.
self updatePosition.
^ Character cr!
----- Method: LimitingLineStreamWrapper>>nextLine (in category 'accessing') -----
nextLine
| thisLine |
self atEnd ifTrue: [^nil].
thisLine _ line.
line _ stream nextLine.
^thisLine
!
----- Method: LimitingLineStreamWrapper>>peekLine (in category 'accessing') -----
peekLine
self atEnd ifTrue: [^nil].
^ line!
----- Method: LimitingLineStreamWrapper>>printOn: (in category 'printing') -----
printOn: aStream
super printOn: aStream.
aStream nextPutAll: ' on '.
stream printOn: aStream!
----- Method: LimitingLineStreamWrapper>>setStream:delimiter: (in category 'private') -----
setStream: aStream delimiter: aString
stream _ aStream.
line _ stream nextLine.
self delimiter: aString. "sets position"
!
----- Method: LimitingLineStreamWrapper>>skipThisLine (in category 'accessing') -----
skipThisLine
line _ stream nextLine.
self updatePosition.
!
----- Method: LimitingLineStreamWrapper>>upToEnd (in category 'accessing') -----
upToEnd
| ln |
^String streamContents: [:strm |
[(ln _ self nextLine) isNil] whileFalse: [
strm nextPutAll: ln; cr]]!
----- Method: LimitingLineStreamWrapper>>updatePosition (in category 'accessing') -----
updatePosition
"Call this before doing character-based access"
position _ self atEnd ifFalse: [0]!
ArrayedCollection subclass: #Text
instanceVariableNames: 'string runs'
classVariableNames: ''
poolDictionaries: 'TextConstants'
category: 'Collections-Text'!
!Text commentStamp: '<historical>' prior: 0!
I represent a character 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. A Text associates a set of TextAttributes with each character in its character string. These attributes may be font numbers, emphases such as bold or italic, or hyperling actions. Font numbers are interpreted relative to whatever textStyle appears, along with the text, in a Paragraph. Since most characters have the same attributes as their neighbors, the attributes are stored in a RunArray for efficiency. Each of my instances has
string a String
runs a RunArray!
----- Method: Text class>>addAttribute:toArray: (in category 'private') -----
addAttribute: att toArray: others
"Add a new text attribute to an existing set"
"NOTE: The use of reset and set in this code is a specific
hack for merging TextKerns."
att reset.
^ Array streamContents:
[:strm | others do:
[:other | (att dominates: other) ifFalse: [strm nextPut: other]].
att set ifTrue: [strm nextPut: att]]!
----- Method: Text class>>fromString: (in category 'instance creation') -----
fromString: aString
"Answer an instance of me whose characters are those of the argument, aString."
^ self string: aString attribute: (TextFontChange fontNumber: TextStyle default defaultFontIndex)!
----- Method: Text class>>fromUser (in category 'instance creation') -----
fromUser
"Answer an instance of me obtained by requesting the user to type a string."
"Text fromUser"
^ self fromString:
(FillInTheBlank request: 'Enter text followed by carriage return')
!
----- Method: Text class>>initTextConstants (in category 'class initialization') -----
initTextConstants
"Initialize constants shared by classes associated with text display, e.g.,
Space, Tab, Cr, Bs, ESC."
"1/24/96 sw: in exasperation and confusion, changed cmd-g mapping from 231 to 232 to see if I could gain any relief?!!"
| letter varAndValue tempArray width |
"CtrlA..CtrlZ, Ctrla..Ctrlz"
letter _ $A.
#( 212 230 228 196 194 226 241 243 214 229 200 217 246
245 216 202 210 239 211 240 197 198 209 215 242 231
1 166 228 132 130 12 232 179 150 165 136 153 182
14 15 138 17 18 19 11 21 134 145 151 178 167 ) do:
[:kbd |
TextConstants at: ('Ctrl', letter asSymbol) asSymbol put: kbd asCharacter.
letter _ letter == $Z ifTrue: [$a] ifFalse: [(letter asciiValue + 1) asCharacter]].
varAndValue _ #(
Space 32
Tab 9
CR 13
Enter 3
BS 8
BS2 158
ESC 160
Clear 173
).
varAndValue size odd ifTrue: [self error: 'unpaired text constant'].
(2 to: varAndValue size by: 2) do:
[:i | TextConstants at: (varAndValue at: i - 1) put: (varAndValue at: i) asCharacter].
varAndValue _ #(
CtrlDigits (159 144 143 128 127 129 131 180 149 135)
CtrlOpenBrackets (201 7 218 249 219 15)
"lparen gottn by ctrl-_ = 201; should be 213 but can't type that on Mac"
"location of non-character stop conditions"
EndOfRun 257
CrossedX 258
"values for alignment"
LeftFlush 0
RightFlush 1
Centered 2
Justified 3
"subscripts for a marginTabsArray tuple"
LeftMarginTab 1
RightMarginTab 2
"font faces"
Basal 0
Bold 1
Italic 2
"in case font doesn't have a width for space character"
"some plausible numbers-- are they the right ones?"
DefaultSpace 4
DefaultTab 24
DefaultLineGrid 16
DefaultBaseline 12
DefaultFontFamilySize 3 "basal, bold, italic"
).
varAndValue size odd ifTrue: [self error: 'unpaired text constant'].
(2 to: varAndValue size by: 2) do:
[:i | TextConstants at: (varAndValue at: i - 1) put: (varAndValue at: i)].
TextConstants at: #DefaultRule put: Form over.
TextConstants at: #DefaultMask put: Color black.
width _ Display width max: 720.
tempArray _ Array new: width // DefaultTab.
1 to: tempArray size do:
[:i | tempArray at: i put: DefaultTab * i].
TextConstants at: #DefaultTabsArray put: tempArray.
tempArray _ Array new: (width // DefaultTab) // 2.
1 to: tempArray size do:
[:i | tempArray at: i put: (Array with: (DefaultTab*i) with: (DefaultTab*i))].
TextConstants at: #DefaultMarginTabsArray put: tempArray.
"Text initTextConstants "!
----- Method: Text class>>initialize (in category 'class initialization') -----
initialize "Text initialize"
"Initialize constants shared by classes associated with text display."
TextConstants at: #CaretForm put:
(Form extent: 16 at 5
fromArray: #(2r001100e26 2r001100e26 2r011110e26 2r111111e26 2r110011e26)
offset: -3 at 0).
self initTextConstants!
----- Method: Text class>>new: (in category 'instance creation') -----
new: stringSize
^self fromString: (String new: stringSize)!
----- Method: Text class>>streamContents: (in category 'instance creation') -----
streamContents: blockWithArg
| stream |
stream _ TextStream on: (self new: 400).
blockWithArg value: stream.
^ stream contents!
----- Method: Text class>>string:attribute: (in category 'instance creation') -----
string: aString attribute: att
"Answer an instance of me whose characters are aString.
att is a TextAttribute."
^self string: aString attributes: (Array with: att)!
----- Method: Text class>>string:attributes: (in category 'instance creation') -----
string: aString attributes: atts
"Answer an instance of me whose characters are those of aString.
atts is an array of TextAttributes."
^self string: aString runs: (RunArray new: aString size withAll: atts)!
----- Method: Text class>>string:emphasis: (in category 'instance creation') -----
string: aString emphasis: emphasis
"This is an old method that is mainly used by old applications"
emphasis isNumber ifTrue:
[self halt: 'Numeric emphasis is not supported in Squeak'.
"But if you proceed, we will do our best to give you what you want..."
^ self string: aString runs: (RunArray new: aString size withAll:
(Array with: (TextFontChange new fontNumber: emphasis)))].
^ self string: aString attributes: emphasis!
----- Method: Text class>>string:runs: (in category 'private') -----
string: aString runs: anArray
^self basicNew setString: aString setRuns: anArray!
----- Method: Text>>= (in category 'comparing') -----
= other
"Am I equal to the other Text or String?
***** Warning ***** Two Texts are considered equal if they have the same characters in them. They might have completely different emphasis, fonts, sizes, text actions, or embedded morphs. If you need to find out if one is a true copy of the other, you must do (text1 = text2 and: [text1 runs = text2 runs])."
other isText ifTrue: ["This is designed to run fast even for megabytes"
^ string == other string or: [string = other string]].
other isString ifTrue: [^ string == other or: [string = other]].
^ false!
----- Method: Text>>addAttribute: (in category 'emphasis') -----
addAttribute: att
^ self addAttribute: att from: 1 to: self size!
----- Method: Text>>addAttribute:from:to: (in category 'emphasis') -----
addAttribute: att from: start to: stop
"Set the attribute for characters in the interval start to stop."
runs _ runs copyReplaceFrom: start to: stop
with: ((runs copyFrom: start to: stop)
mapValues:
[:attributes | Text addAttribute: att toArray: attributes])
!
----- Method: Text>>alignmentAt:ifAbsent: (in category 'emphasis') -----
alignmentAt: characterIndex ifAbsent: aBlock
| attributes emph |
self size = 0 ifTrue: [^aBlock value].
emph _ nil.
attributes _ runs at: characterIndex.
attributes do:[:att | (att isKindOf: TextAlignment) ifTrue:[emph _ att]].
^ emph ifNil: aBlock ifNotNil:[emph alignment]!
----- Method: Text>>allBold (in category 'emphasis') -----
allBold
"Force this whole text to be bold."
string size = 0 ifTrue: [^self].
self makeBoldFrom: 1 to: string size!
----- Method: Text>>append: (in category 'accessing') -----
append: stringOrText
self replaceFrom: string size + 1
to: string size with: stringOrText!
----- Method: Text>>asDisplayText (in category 'converting') -----
asDisplayText
"Answer a DisplayText whose text is the receiver."
^DisplayText text: self!
----- Method: Text>>asNumber (in category 'converting') -----
asNumber
"Answer the number created by interpreting the receiver as the textual
representation of a number."
^string asNumber!
----- Method: Text>>asOctetStringText (in category 'converting') -----
asOctetStringText
string class == WideString ifTrue: [
^ self class string: string asOctetString runs: self runs copy.
].
^self.
!
----- Method: Text>>asString (in category 'converting') -----
asString
"Answer a String representation of the textual receiver."
^string!
----- Method: Text>>asStringOrText (in category 'converting') -----
asStringOrText
"Answer the receiver itself."
^self!
----- Method: Text>>asText (in category 'converting') -----
asText
"Answer the receiver itself."
^self!
----- Method: Text>>asUrl (in category 'converting') -----
asUrl
^self asString asUrl!
----- Method: Text>>asUrlRelativeTo: (in category 'converting') -----
asUrlRelativeTo: aUrl
^self asString asUrlRelativeTo: aUrl!
----- Method: Text>>askIfAddStyle:req: (in category 'attributes') -----
askIfAddStyle: priorMethod req: requestor
"Ask the user if we have a complex style (i.e. bold) for the first time"
| tell answ old |
(Preferences browseWithPrettyPrint and: [Preferences colorWhenPrettyPrinting])
ifTrue: [self couldDeriveFromPrettyPrinting ifTrue: [^ self asString]].
self runs coalesce.
self unembellished ifTrue: [^ self asString].
priorMethod ifNotNil: [old _ priorMethod getSourceFromFile].
(old == nil or: [old unembellished])
ifTrue:
[tell _ 'This method contains style for the first time (e.g. bold or colored text).
Do you really want to save the style info?' translated.
answ _ (PopUpMenu labels: 'Save method with style
Save method simply' translated)
startUpWithCaption: tell.
answ = 2 ifTrue: [^ self asString]]!
----- Method: Text>>at: (in category 'accessing') -----
at: index
^string at: index!
----- Method: Text>>at:put: (in category 'accessing') -----
at: index put: character
^string at: index put: character!
----- Method: Text>>attributesAt: (in category 'emphasis') -----
attributesAt: characterIndex
"Answer the code for characters in the run beginning at characterIndex."
"NB: no senders any more (supplanted by #attributesAt:forStyle: but retained for the moment in order not to break user code that may exist somewhere that still calls this"
| attributes |
self size = 0
ifTrue: [^ Array with: (TextFontChange new fontNumber: 1)]. "null text tolerates access"
attributes _ runs at: characterIndex.
^ attributes!
----- Method: Text>>attributesAt:do: (in category 'emphasis') -----
attributesAt: characterIndex do: aBlock
"Answer the code for characters in the run beginning at characterIndex."
"NB: no senders any more (supplanted by #attributesAt:forStyle: but retained for the moment in order not to break user code that may exist somewhere that still calls this"
self size = 0 ifTrue:[^self].
(runs at: characterIndex) do: aBlock!
----- Method: Text>>attributesAt:forStyle: (in category 'emphasis') -----
attributesAt: characterIndex forStyle: aTextStyle
"Answer the code for characters in the run beginning at characterIndex."
| attributes |
self size = 0
ifTrue: [^ Array with: (TextFontChange new fontNumber: aTextStyle defaultFontIndex)]. "null text tolerates access"
attributes _ runs at: characterIndex.
^ attributes!
----- Method: Text>>copy (in category 'copying') -----
copy
^ self class new setString: string copy setRuns: runs copy
!
----- Method: Text>>copyFrom:to: (in category 'copying') -----
copyFrom: start to: stop
"Answer a copied subrange of the receiver."
| realStart realStop |
stop > self size
ifTrue: [realStop _ self size] "handle selection at end of string"
ifFalse: [realStop _ stop].
start < 1
ifTrue: [realStart _ 1] "handle selection before start of string"
ifFalse: [realStart _ start].
^Text
string: (string copyFrom: realStart to: realStop)
runs: (runs copyFrom: realStart to: realStop)!
----- Method: Text>>copyReplaceFrom:to:with: (in category 'copying') -----
copyReplaceFrom: start to: stop with: aTextOrString
| txt |
txt _ aTextOrString asText. "might be a string"
^self class
string: (string copyReplaceFrom: start to: stop with: txt string)
runs: (runs copyReplaceFrom: start to: stop with: txt runs)
!
----- Method: Text>>copyReplaceTokens:with: (in category 'copying') -----
copyReplaceTokens: oldSubstring with: newSubstring
"Replace all occurrences of oldSubstring that are surrounded
by non-alphanumeric characters"
^ self copyReplaceAll: oldSubstring with: newSubstring asTokens: true
"'File asFile Files File''s File' copyReplaceTokens: 'File' with: 'Snick'"!
----- Method: Text>>couldDeriveFromPrettyPrinting (in category 'attributes') -----
couldDeriveFromPrettyPrinting
"Return true if the receiver has any TextAttributes that are functional rather than simply appearance-related"
runs values do:
[:emphArray | emphArray do:
[:emph | emph couldDeriveFromPrettyPrinting ifFalse: [^ false]]].
^ true!
----- Method: Text>>deepCopy (in category 'copying') -----
deepCopy
^ self copy "Both string and runs are assumed to be read-only"!
----- Method: Text>>embeddedMorphs (in category 'accessing') -----
embeddedMorphs
"return the list of morphs embedded in me"
| morphs |
morphs := IdentitySet new.
runs withStartStopAndValueDo:
[:start :stop :attribs |
attribs
do: [:attrib | attrib anchoredMorph ifNotNil: [morphs add: attrib anchoredMorph]]].
^morphs select: [:m | m isMorph]!
----- Method: Text>>embeddedMorphsFrom:to: (in category 'accessing') -----
embeddedMorphsFrom: start to: stop
"return the list of morphs embedded in me"
| morphs |
morphs := IdentitySet new.
runs
runsFrom: start
to: stop
do:
[:attribs |
attribs
do: [:attr | attr anchoredMorph ifNotNil: [morphs add: attr anchoredMorph]]].
^morphs select: [:m | m isMorph]!
----- Method: Text>>emphasisAt: (in category 'emphasis') -----
emphasisAt: characterIndex
"Answer the fontfor characters in the run beginning at characterIndex."
| attributes emph |
self size = 0 ifTrue: [^ 0]. "null text tolerates access"
emph _ 0.
attributes _ runs at: characterIndex.
attributes do:
[:att | emph _ emph bitOr: att emphasisCode].
^ emph
!
----- Method: Text>>find: (in category 'emphasis') -----
find: attribute
"Return the first interval over which this attribute applies"
| begin end |
begin _ 0.
runs withStartStopAndValueDo:
[:start :stop :attributes |
(attributes includes: attribute)
ifTrue: [begin = 0 ifTrue: [begin _ start].
end _ stop]
ifFalse: [begin > 0 ifTrue: [^ begin to: end]]].
begin > 0 ifTrue: [^ begin to: end].
^ nil!
----- Method: Text>>findString:startingAt: (in category 'accessing') -----
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."
^string findString: aString asString startingAt: start!
----- Method: Text>>findString:startingAt:caseSensitive: (in category 'accessing') -----
findString: aString startingAt: start caseSensitive: caseSensitive
"Answer the index of subString within the receiver, starting at index
start. If the receiver does not contain subString, answer 0."
^string findString: aString asString startingAt: start caseSensitive: caseSensitive!
----- Method: Text>>fontAt:withStyle: (in category 'emphasis') -----
fontAt: characterIndex withStyle: aTextStyle
"Answer the fontfor characters in the run beginning at characterIndex."
| attributes font |
self size = 0 ifTrue: [^ aTextStyle defaultFont]. "null text tolerates access"
attributes _ runs at: characterIndex.
font _ aTextStyle defaultFont. "default"
attributes do:
[:att | att forFontInStyle: aTextStyle do: [:f | font _ f]].
^ font!
----- Method: Text>>fontNumberAt: (in category 'emphasis') -----
fontNumberAt: characterIndex
"Answer the fontNumber for characters in the run beginning at characterIndex."
| attributes fontNumber |
self size = 0 ifTrue: [^1]. "null text tolerates access"
attributes _ runs at: characterIndex.
fontNumber _ 1.
attributes do: [:att | (att isMemberOf: TextFontChange) ifTrue: [fontNumber _ att fontNumber]].
^ fontNumber
!
----- Method: Text>>hash (in category 'comparing') -----
hash
"#hash is implemented, because #= is implemented. We are now equal to a string with the same characters. Hash must reflect that."
^ string hash!
----- Method: Text>>howManyMatch: (in category 'comparing') -----
howManyMatch: aString
^ self string howManyMatch: aString!
----- Method: Text>>isText (in category 'comparing') -----
isText
^ true!
----- Method: Text>>isoToSqueak (in category 'converting') -----
isoToSqueak
^self "no longer needed"!
----- Method: Text>>lineCount (in category 'accessing') -----
lineCount
^ string lineCount!
----- Method: Text>>macToSqueak (in category 'converting') -----
macToSqueak
"Convert the receiver from MacRoman to Squeak encoding"
^ self class new setString: string macToSqueak setRuns: runs copy!
----- Method: Text>>makeBoldFrom:to: (in category 'emphasis') -----
makeBoldFrom: start to: stop
^ self addAttribute: TextEmphasis bold from: start to: stop!
----- Method: Text>>makeSelectorBold (in category 'emphasis') -----
makeSelectorBold
"For formatting Smalltalk source code, set the emphasis of that portion of
the receiver's string that parses as a message selector to be bold."
| parser i |
string size = 0 ifTrue: [^ self].
i _ 0.
[(string at: (i _ i + 1)) isSeparator] whileTrue.
(string at: i) = $[ ifTrue: [^ self]. "block, no selector"
(parser _ Compiler parserClass new) parseSelector: string.
self makeBoldFrom: 1 to: (parser endOfLastToken min: string size)!
----- Method: Text>>makeSelectorBoldIn: (in category 'emphasis') -----
makeSelectorBoldIn: aClass
"For formatting Smalltalk source code, set the emphasis of that portion of
the receiver's string that parses as a message selector to be bold."
| parser |
string size = 0 ifTrue: [^self].
(parser _ aClass parserClass new) parseSelector: string.
self makeBoldFrom: 1 to: (parser endOfLastToken min: string size)!
----- Method: Text>>prepend: (in category 'accessing') -----
prepend: stringOrText
self replaceFrom: 1 to: 0 with: stringOrText!
----- Method: Text>>printOn: (in category 'printing') -----
printOn: aStream
self printNameOn: aStream.
aStream nextPutAll: ' for '; print: string!
----- Method: Text>>rangeOf:startingAt: (in category 'accessing') -----
rangeOf: attribute startingAt: index
"Answer an interval that gives the range of attribute at index position index. An empty interval with start value index is returned when the attribute is not present at position index. "
^string size = 0
ifTrue: [index to: index - 1]
ifFalse: [runs rangeOf: attribute startingAt: index]!
----- Method: Text>>rangeOf:startingAt:forStyle: (in category 'accessing') -----
rangeOf: attribute startingAt: index forStyle: aTextStyle
"aTextStyle is not really needed, it is kept for compatibility with an earlier method version "
self deprecated: 'Use Text>>rangeOf:startingAt: instead.'.
^self rangeOf: attribute startingAt: index!
----- Method: Text>>removeAttribute:from:to: (in category 'emphasis') -----
removeAttribute: att from: start to: stop
"Remove the attribute over the interval start to stop."
runs _ runs copyReplaceFrom: start to: stop
with: ((runs copyFrom: start to: stop)
mapValues:
[:attributes | attributes copyWithout: att])
!
----- Method: Text>>removeAttributesThat:replaceAttributesThat:by: (in category 'converting') -----
removeAttributesThat: removalBlock replaceAttributesThat: replaceBlock by: convertBlock
"Enumerate all attributes in the receiver. Remove those passing removalBlock and replace those passing replaceBlock after converting it through convertBlock"
| added removed new |
"Deliberately optimized for the no-op default."
added _ removed _ nil.
runs withStartStopAndValueDo: [ :start :stop :attribs |
attribs do: [ :attrib |
(removalBlock value: attrib) ifTrue:[
removed ifNil:[removed _ WriteStream on: #()].
removed nextPut: {start. stop. attrib}.
] ifFalse:[
(replaceBlock value: attrib) ifTrue:[
removed ifNil:[removed _ WriteStream on: #()].
removed nextPut: {start. stop. attrib}.
new _ convertBlock value: attrib.
added ifNil:[added _ WriteStream on: #()].
added nextPut: {start. stop. new}.
].
].
].
].
(added == nil and:[removed == nil]) ifTrue:[^self].
"otherwise do the real work"
removed ifNotNil:[removed contents do:[:spec|
self removeAttribute: spec last from: spec first to: spec second]].
added ifNotNil:[added contents do:[:spec|
self addAttribute: spec last from: spec first to: spec second]].!
----- Method: Text>>replaceFrom:to:with: (in category 'accessing') -----
replaceFrom: start to: stop with: aText
| txt |
txt _ aText asText. "might be a string"
string _ string copyReplaceFrom: start to: stop with: txt string.
runs _ runs copyReplaceFrom: start to: stop with: txt runs!
----- Method: Text>>replaceFrom:to:with:startingAt: (in category 'converting') -----
replaceFrom: start to: stop with: replacement startingAt: repStart
"This destructively replaces elements from start to stop in the receiver starting at index, repStart, in replacementCollection. Do it to both the string and the runs."
| rep newRepRuns |
rep _ replacement asText. "might be a string"
string replaceFrom: start to: stop with: rep string startingAt: repStart.
newRepRuns _ rep runs copyFrom: repStart to: repStart + stop - start.
runs _ runs copyReplaceFrom: start to: stop with: newRepRuns!
----- Method: Text>>reversed (in category 'converting') -----
reversed
"Answer a copy of the receiver with element order reversed."
^ self class string: string reversed runs: runs reversed.
" It is assumed that self size = runs size holds. "!
----- Method: Text>>runLengthFor: (in category 'emphasis') -----
runLengthFor: characterIndex
"Answer the count of characters remaining in run beginning with
characterIndex."
^runs runLengthAt: characterIndex!
----- Method: Text>>runs (in category 'private') -----
runs
^runs!
----- Method: Text>>runs: (in category 'accessing') -----
runs: anArray
runs := anArray!
----- Method: Text>>setString:setRuns: (in category 'private') -----
setString: aString setRuns: anArray
string _ aString.
runs _ anArray!
----- Method: Text>>setString:setRunsChecking: (in category 'private') -----
setString: aString setRunsChecking: aRunArray
"Check runs and do the best you can to make them fit..."
string _ aString.
"check the runs"
aRunArray ifNil: [^ aString asText].
(aRunArray isKindOf: RunArray) ifFalse: [^ aString asText].
aRunArray runs size = aRunArray values size ifFalse: [^ aString asText].
(aRunArray values includes: #()) ifTrue: [^ aString asText]. "not allowed?"
aRunArray size = aString size ifFalse: [^ aString asText].
runs _ aRunArray.!
----- Method: Text>>size (in category 'accessing') -----
size
^string size!
----- Method: Text>>squeakToIso (in category 'converting') -----
squeakToIso
^self "no longer needed"!
----- Method: Text>>squeakToMac (in category 'converting') -----
squeakToMac
"Convert the receiver from Squeak to MacRoman encoding"
^ self class new setString: string squeakToMac setRuns: runs copy!
----- Method: Text>>storeOn: (in category 'printing') -----
storeOn: aStream
aStream nextPutAll: '(Text string: ';
store: string;
nextPutAll: ' runs: ';
store: runs;
nextPut: $)!
----- Method: Text>>string (in category 'accessing') -----
string
"Answer the string representation of the receiver."
^string!
----- Method: Text>>translated (in category 'converting') -----
translated
^ string translated!
----- Method: Text>>unembellished (in category 'attributes') -----
unembellished
"Return true if the only emphases are the default font and bold"
| font1 bold |
font1 _ TextFontChange defaultFontChange.
bold _ TextEmphasis bold.
Preferences ignoreStyleIfOnlyBold ifFalse:
["Ignore font1 only or font1-bold followed by font1-plain"
^ (runs values = (Array with: (Array with: font1)))
or: [runs values = (Array with: (Array with: font1 with: bold)
with: (Array with: font1))]].
"If preference is set, then ignore any combo of font1 and bold"
runs withStartStopAndValueDo:
[:start :stop :emphArray |
emphArray do:
[:emph | (font1 = emph or: [bold = emph]) ifFalse: [^ false]]].
^ true!
----- Method: Text>>withSqueakLineEndings (in category 'converting') -----
withSqueakLineEndings
"Answer a copy of myself in which all sequences of <CR><LF> or <LF> have been changed to <CR>"
| newText |
(string includes: Character lf) ifFalse: [ ^self copy ].
newText _ self copyReplaceAll: String crlf with: String cr asTokens: false.
(newText asString includes: Character lf) ifFalse: [ ^newText ].
^newText copyReplaceAll: String lf with: String cr asTokens: false.!
More information about the Packages
mailing list